[project @ 2003-07-23 13:39:11 by simonmar]

[ghc-hetmet.git] / ghc / compiler / coreSyn / CorePrep.lhs

diff --git a/ghc/compiler/coreSyn/CorePrep.lhs b/ghc/compiler/coreSyn/CorePrep.lhs
index e55bca8..d2515c9 100644 (file)
--- a/ghc/compiler/coreSyn/CorePrep.lhs
+++ b/ghc/compiler/coreSyn/CorePrep.lhs
@@ -16,16 +16,17 @@ import CoreLint     ( endPass )
 import CoreSyn
 import Type    ( Type, applyTy, splitFunTy_maybe, 
                  isUnLiftedType, isUnboxedTupleType, seqType )
+import TcType  ( TyThing( AnId ) )
 import NewDemand  ( Demand, isStrictDmd, lazyDmd, StrictSig(..), DmdType(..) )
 import Var     ( Var, Id, setVarUnique )
 import VarSet
 import VarEnv
 import Id      ( mkSysLocal, idType, idNewDemandInfo, idArity,
-                 isFCallId, isGlobalId, 
+                 isFCallId, isGlobalId, isImplicitId,
                  isLocalId, hasNoBinding, idNewStrictness, 
-                 isDataConId_maybe, idUnfolding
+                 idUnfolding, isDataConWorkId_maybe
                )
-import HscTypes ( ModGuts(..), ModGuts, implicitTyThingIds, typeEnvElts )
+import HscTypes   ( TypeEnv, typeEnvElts )
 import BasicTypes ( TopLevelFlag(..), isTopLevel, isNotTopLevel,
                    RecFlag(..), isNonRec
                  )
@@ -96,23 +97,23 @@ any trivial or useless bindings.
 -- -----------------------------------------------------------------------------
 
 \begin{code}
-corePrepPgm :: DynFlags -> ModGuts -> IO ModGuts
-corePrepPgm dflags mod_impl
+corePrepPgm :: DynFlags -> [CoreBind] -> TypeEnv -> IO [CoreBind]
+corePrepPgm dflags binds types
   = do showPass dflags "CorePrep"
        us <- mkSplitUniqSupply 's'
 
-       let implicit_binds = mkImplicitBinds (mg_types mod_impl)
+       let implicit_binds = mkImplicitBinds types
                -- NB: we must feed mkImplicitBinds through corePrep too
                -- so that they are suitably cloned and eta-expanded
 
            binds_out = initUs_ us (
-                         corePrepTopBinds (mg_binds mod_impl)  `thenUs` \ floats1 ->
+                         corePrepTopBinds binds        `thenUs` \ floats1 ->
                          corePrepTopBinds implicit_binds       `thenUs` \ floats2 ->
                          returnUs (deFloatTop (floats1 `appOL` floats2))
                        )
            
         endPass dflags "CorePrep" Opt_D_dump_prep binds_out
-       return (mod_impl { mg_binds = binds_out })
+       return binds_out
 
 corePrepExpr :: DynFlags -> CoreExpr -> IO CoreExpr
 corePrepExpr dflags expr
@@ -154,14 +155,18 @@ partial applications. But it's easier to let them through.
 \begin{code}
 mkImplicitBinds type_env
   = [ NonRec id (get_unfolding id)
-    | id <- implicitTyThingIds (typeEnvElts type_env) ]
+    | AnId id <- typeEnvElts type_env, isImplicitId id ]
+       -- The type environment already contains all the implicit Ids, 
+       -- so we just filter them out
+       --
        -- The etaExpand is so that the manifest arity of the
        -- binding matches its claimed arity, which is an 
        -- invariant of top level bindings going into the code gen
 
 get_unfolding id       -- See notes above
-  | Just data_con <- isDataConId_maybe id = Var id     -- The ice is thin here, but it works
-  | otherwise                            = unfoldingTemplate (idUnfolding id)
+  | Just data_con <- isDataConWorkId_maybe id = Var id -- The ice is thin here, but it works
+                                                       -- CorePrep will eta-expand it
+  | otherwise                                = unfoldingTemplate (idUnfolding id)
 \end{code}
        
 
@@ -227,6 +232,19 @@ corePrepTopBinds binds
 --     a = g y
 --     x* = f a
 -- And then x will actually end up case-bound
+--
+-- What happens to the CafInfo on the floated bindings?  By
+-- default, all the CafInfos will be set to MayHaveCafRefs,
+-- which is safe.
+--
+-- This might be pessimistic, because eg. s1 & s2
+-- might not refer to any CAFs and the GC will end up doing
+-- more traversal than is necessary, but it's still better
+-- than not floating the bindings at all, because then
+-- the GC would have to traverse the structure in the heap
+-- instead.  Given this, we decided not to try to get
+-- the CafInfo on the floated bindings correct, because
+-- it looks difficult.
 
 --------------------------------
 corePrepTopBind :: CloneEnv -> CoreBind -> UniqSM (CloneEnv, OrdList FloatingBind)
@@ -449,10 +467,11 @@ corePrepExprFloat env expr@(App _ _)
         where
          ty = exprType fun
 
-    ignore_note        InlineCall = True
-    ignore_note        InlineMe   = True
-    ignore_note        _other     = False
-       -- we don't ignore SCCs, since they require some code generation
+    ignore_note        (CoreNote _) = True 
+    ignore_note        InlineCall   = True
+    ignore_note        InlineMe     = True
+    ignore_note        _other       = False
+       -- We don't ignore SCCs, since they require some code generation
 
 ------------------------------------------------------------------------------
 -- Building the saturated syntax
@@ -626,7 +645,7 @@ tryEta bndrs expr@(App _ _)
     n_remaining = length args - length bndrs
 
     ok bndr (Var arg) = bndr == arg
-    ok bndr other          = False
+    ok bndr other     = False
 
          -- we can't eta reduce something which must be saturated.
     ok_to_eta_reduce (Var f) = not (hasNoBinding f)