[project @ 2003-07-02 13:12:33 by simonpj]

[ghc-hetmet.git] / ghc / compiler / typecheck / TcIfaceSig.lhs

diff --git a/ghc/compiler/typecheck/TcIfaceSig.lhs b/ghc/compiler/typecheck/TcIfaceSig.lhs
index 0c3e896..5295fec 100644 (file)
--- a/ghc/compiler/typecheck/TcIfaceSig.lhs
+++ b/ghc/compiler/typecheck/TcIfaceSig.lhs
@@ -16,7 +16,8 @@ import TcHsSyn                ( TypecheckedCoreBind )
 import TcRnTypes
 import TcRnMonad
 import TcMonoType      ( tcIfaceType, kcHsSigType )
-import TcEnv           ( tcExtendTyVarEnv, tcExtendGlobalValEnv, tcLookupGlobalId )
+import TcEnv           ( tcExtendTyVarEnv, tcExtendGlobalValEnv, tcLookupGlobalId,
+                         tcLookupDataCon )
 
 import RnHsSyn         ( RenamedCoreDecl, RenamedTyClDecl )
 import HsCore
@@ -27,7 +28,7 @@ import CoreUnfold
 import CoreLint                ( lintUnfolding )
 import WorkWrap                ( mkWrapper )
 
-import Id              ( Id, mkVanillaGlobal, mkLocalId, isDataConWrapId_maybe )
+import Id              ( Id, mkVanillaGlobal, mkLocalId )
 import MkId            ( mkFCallId )
 import IdInfo
 import TyCon           ( tyConDataCons, tyConTyVars )
@@ -39,7 +40,7 @@ import Name           ( Name )
 import UniqSupply      ( initUs_ )
 import Outputable      
 import Util            ( zipWithEqual, dropList, equalLength )
-import HscTypes                ( TyThing(..), typeEnvIds )
+import HscTypes                ( typeEnvIds )
 import CmdLineOpts     ( DynFlag(..) )
 \end{code}
 
@@ -54,7 +55,22 @@ signatures.
 tcInterfaceSigs :: [RenamedTyClDecl]   -- Ignore non-sig-decls in these decls
                -> TcM TcGblEnv
                
-tcInterfaceSigs decls = fixM (tc_interface_sigs decls)
+-- May 2003: 
+--     NOTE 1: careful about the side-effected EPS
+--             in the two tcExtendGlobalValueEnv calls
+--     NOTE 2: no point in tying the knot with fixM; all
+--             the important knot-tying comes via the PCS global variable
+
+tcInterfaceSigs decls = 
+  zapEnv (fixM (tc_interface_sigs decls)) `thenM` \ (_,sig_ids) ->
+       -- The zapEnv dramatically trims the environment, solely
+       -- to plug the space leak that would otherwise be caused
+       -- by a rich environment bound into lots of lazy thunks
+       -- The thunks are the lazily-typechecked IdInfo of the 
+       -- imported things.
+
+  tcExtendGlobalValEnv sig_ids getGblEnv  `thenM` \ gbl_env ->
+  returnM gbl_env
        -- We tie a knot so that the Ids read out of interfaces are in scope
        --   when we read their pragmas.
        -- What we rely on is that pragmas are typechecked lazily; if
@@ -85,10 +101,10 @@ tcInterfaceSigs decls = fixM (tc_interface_sigs decls)
        -- bound in this module (and hence not yet processed).
        -- The discarding happens when forkM finds a type error.
 
-tc_interface_sigs decls unf_env 
+tc_interface_sigs decls ~(unf_env, _)
   = sequenceM [do_one d | d@(IfaceSig {}) <- decls]    `thenM` \ sig_ids ->
-    tcExtendGlobalValEnv sig_ids getGblEnv
-       -- Return the extended environment
+    tcExtendGlobalValEnv sig_ids getGblEnv             `thenM` \ gbl_env ->
+    returnM (gbl_env, sig_ids)
   where
     in_scope_vars = typeEnvIds (tcg_type_env unf_env)
        -- When we have hi-boot files, an unfolding might refer to
@@ -115,7 +131,7 @@ tcIdInfo unf_env in_scope_vars name ty info_ins
   where
     -- Set the CgInfo to something sensible but uninformative before
     -- we start; default assumption is that it has CAFs
-    init_info = hasCafIdInfo
+    init_info = vanillaIdInfo
 
     tcPrag info HsNoCafRefs         = returnM (info `setCafInfo`   NoCafRefs)
     tcPrag info (HsArity arity)     = returnM (info `setArityInfo` arity)
@@ -374,11 +390,10 @@ tcConAlt :: UfConAlt Name -> TcM DataCon
 tcConAlt (UfTupleAlt (HsTupCon boxity arity))
   = returnM (tupleCon boxity arity)
 
-tcConAlt (UfDataAlt con_name)
-  = tcVar con_name     `thenM` \ con_id ->
-    returnM (case isDataConWrapId_maybe con_id of
-                   Just con -> con
-                   Nothing  -> pprPanic "tcCoreAlt" (ppr con_id))
+tcConAlt (UfDataAlt con_name)  -- When reading interface files
+                               -- the con_name will be the real name of
+                               -- the data con
+  = tcLookupDataCon con_name
 \end{code}
 
 %************************************************************************