[commit: ghc] ghc-8.0: Fix #12064 by making IfaceClass typechecking more lazy. (479e0bc)
git at git.haskell.org
git at git.haskell.org
Wed Aug 24 22:18:33 UTC 2016
Repository : ssh://git@git.haskell.org/ghc
On branch : ghc-8.0
Link : http://ghc.haskell.org/trac/ghc/changeset/479e0bce4729b84eea6baa29ceee30dc5f99806b/ghc
>---------------------------------------------------------------
commit 479e0bce4729b84eea6baa29ceee30dc5f99806b
Author: Edward Z. Yang <ezyang at cs.stanford.edu>
Date: Sun May 15 16:13:51 2016 -0700
Fix #12064 by making IfaceClass typechecking more lazy.
Summary:
Comes with a test based off of prog006.
Signed-off-by: Edward Z. Yang <ezyang at cs.stanford.edu>
Test Plan: validate
Reviewers: simonpj, austin, bgamari
Subscribers: thomie
Differential Revision: https://phabricator.haskell.org/D2221
GHC Trac Issues: #12064
(cherry picked from commit 8f6d292746217f1fa9f645ff8d191943af1c5771)
>---------------------------------------------------------------
479e0bce4729b84eea6baa29ceee30dc5f99806b
compiler/iface/TcIface.hs | 41 ++++++++++++++--------
compiler/typecheck/TcRnDriver.hs | 2 +-
testsuite/tests/typecheck/should_compile/T12064.hs | 4 +++
.../tests/typecheck/should_compile/T12064.hs-boot | 2 ++
.../tests/typecheck/should_compile/T12064a.hs | 4 +++
testsuite/tests/typecheck/should_compile/all.T | 2 ++
6 files changed, 39 insertions(+), 16 deletions(-)
diff --git a/compiler/iface/TcIface.hs b/compiler/iface/TcIface.hs
index 22ecae7..13df037 100644
--- a/compiler/iface/TcIface.hs
+++ b/compiler/iface/TcIface.hs
@@ -147,7 +147,10 @@ typecheckIface iface
-- Finished
; traceIf (vcat [text "Finished typechecking interface for" <+> ppr (mi_module iface),
- text "Type envt:" <+> ppr type_env])
+ -- Careful! If we tug on the TyThing thunks too early
+ -- we'll infinite loop with hs-boot. See #10083 for
+ -- an example where this would cause non-termination.
+ text "Type envt:" <+> ppr (map fst names_w_things)])
; return $ ModDetails { md_types = type_env
, md_insts = insts
, md_fam_insts = fam_insts
@@ -189,7 +192,7 @@ tcHiBootIface hsc_src mod
-- And that's fine, because if M's ModInfo is in the HPT, then
-- it's been compiled once, and we don't need to check the boot iface
then do { hpt <- getHpt
- ; case lookupUFM hpt (moduleName mod) of
+ ; case lookupHptByModule hpt mod of
Just info | mi_boot (hm_iface info)
-> return (mkSelfBootInfo (hm_details info))
_ -> return NoSelfBoot }
@@ -426,20 +429,23 @@ tc_iface_decl _parent ignore_prags
tc_sig :: IfaceClassOp -> IfL TcMethInfo
tc_sig (IfaceClassOp occ rdr_ty dm)
= do { op_name <- lookupIfaceTop occ
- ; ~(op_ty, dm') <- forkM (mk_op_doc op_name rdr_ty) $
- do { ty <- tcIfaceType rdr_ty
- ; dm' <- tc_dm dm
- ; return (ty, dm') }
+ ; let doc = mk_op_doc op_name rdr_ty
+ ; op_ty <- forkM (doc <+> text "ty") $ tcIfaceType rdr_ty
-- Must be done lazily for just the same reason as the
-- type of a data con; to avoid sucking in types that
-- it mentions unless it's necessary to do so
+ ; dm' <- tc_dm doc dm
; return (op_name, op_ty, dm') }
- tc_dm :: Maybe (DefMethSpec IfaceType) -> IfL (Maybe (DefMethSpec (SrcSpan, Type)))
- tc_dm Nothing = return Nothing
- tc_dm (Just VanillaDM) = return (Just VanillaDM)
- tc_dm (Just (GenericDM ty)) = do { ty' <- tcIfaceType ty
- ; return (Just (GenericDM (noSrcSpan, ty'))) }
+ tc_dm :: SDoc
+ -> Maybe (DefMethSpec IfaceType)
+ -> IfL (Maybe (DefMethSpec (SrcSpan, Type)))
+ tc_dm _ Nothing = return Nothing
+ tc_dm _ (Just VanillaDM) = return (Just VanillaDM)
+ tc_dm doc (Just (GenericDM ty))
+ = do { -- Must be done lazily to avoid sucking in types
+ ; ty' <- forkM (doc <+> text "dm") $ tcIfaceType ty
+ ; return (Just (GenericDM (noSrcSpan, ty'))) }
tc_at cls (IfaceAT tc_decl if_def)
= do ATyCon tc <- tc_iface_decl (Just cls) ignore_prags tc_decl
@@ -1277,7 +1283,7 @@ tcPragExpr name expr
where
doc = text "Unfolding of" <+> ppr name
- get_in_scope :: IfL [Var] -- Totally disgusting; but just for linting
+ get_in_scope :: IfL VarSet -- Totally disgusting; but just for linting
get_in_scope
= do { (gbl_env, lcl_env) <- getEnvs
; rec_ids <- case if_rec_types gbl_env of
@@ -1285,9 +1291,14 @@ tcPragExpr name expr
Just (_, get_env) -> do
{ type_env <- setLclEnv () get_env
; return (typeEnvIds type_env) }
- ; return (varEnvElts (if_tv_env lcl_env) ++
- varEnvElts (if_id_env lcl_env) ++
- rec_ids) }
+ ; return (bindingsVars (if_tv_env lcl_env) `unionVarSet`
+ bindingsVars (if_id_env lcl_env) `unionVarSet`
+ mkVarSet rec_ids) }
+
+ bindingsVars :: FastStringEnv Var -> VarSet
+ bindingsVars ufm = mkVarSet $ nonDetEltsUFM ufm
+ -- It's OK to use nonDetEltsUFM here because we immediately forget
+ -- the ordering by creating a set
{-
************************************************************************
diff --git a/compiler/typecheck/TcRnDriver.hs b/compiler/typecheck/TcRnDriver.hs
index e7328b9..b05e4b4 100644
--- a/compiler/typecheck/TcRnDriver.hs
+++ b/compiler/typecheck/TcRnDriver.hs
@@ -367,7 +367,7 @@ tcRnModuleTcRnM hsc_env hsc_src
Nothing -> return tcg_env) ;
-- The new type env is already available to stuff slurped from
- -- interface files, via TcEnv.updateGlobalTypeEnv
+ -- interface files, via TcEnv.setGlobalTypeEnv
-- It's important that this includes the stuff in checkHiBootIface,
-- because the latter might add new bindings for boot_dfuns,
-- which may be mentioned in imported unfoldings
diff --git a/testsuite/tests/typecheck/should_compile/T12064.hs b/testsuite/tests/typecheck/should_compile/T12064.hs
new file mode 100644
index 0000000..0c3d1b3
--- /dev/null
+++ b/testsuite/tests/typecheck/should_compile/T12064.hs
@@ -0,0 +1,4 @@
+{-# LANGUAGE ExistentialQuantification #-}
+module T12064 where
+import T12064a
+data D = forall n. K n => DCon n
diff --git a/testsuite/tests/typecheck/should_compile/T12064.hs-boot b/testsuite/tests/typecheck/should_compile/T12064.hs-boot
new file mode 100644
index 0000000..4536cf3
--- /dev/null
+++ b/testsuite/tests/typecheck/should_compile/T12064.hs-boot
@@ -0,0 +1,2 @@
+module T12064 where
+data D
diff --git a/testsuite/tests/typecheck/should_compile/T12064a.hs b/testsuite/tests/typecheck/should_compile/T12064a.hs
new file mode 100644
index 0000000..381edfc
--- /dev/null
+++ b/testsuite/tests/typecheck/should_compile/T12064a.hs
@@ -0,0 +1,4 @@
+module T12064a where
+import {-# SOURCE #-} T12064
+class K a where
+ kfun :: D -> a
diff --git a/testsuite/tests/typecheck/should_compile/all.T b/testsuite/tests/typecheck/should_compile/all.T
index e298a52..fd62707 100644
--- a/testsuite/tests/typecheck/should_compile/all.T
+++ b/testsuite/tests/typecheck/should_compile/all.T
@@ -512,3 +512,5 @@ test('T11754', normal, compile, [''])
test('T11811', normal, compile, [''])
test('T11793', normal, compile, [''])
test('T11947', normal, compile, [''])
+test('T12064', extra_clean(['T12064.hi-boot', 'T12064.o-boot', 'T11062a.hi', 'T11062a.o']),
+ multimod_compile, ['T12064', '-v0'])
More information about the ghc-commits
mailing list