X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FcoreSyn%2FCorePrep.lhs;h=d2515c9cb53951579a8a37ede0c0673eb5b110f5;hb=7d71bf0b4e294a7cb62037aedd087519ead9ade8;hp=e55bca842ea6ca5fcd040b6fc534547e9806b4b7;hpb=9af77fa423926fbda946b31e174173d0ec5ebac8;p=ghc-hetmet.git

diff --git a/ghc/compiler/coreSyn/CorePrep.lhs b/ghc/compiler/coreSyn/CorePrep.lhs
index e55bca8..d2515c9 100644
--- 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)