X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FstgSyn%2FCoreToStg.lhs;fp=ghc%2Fcompiler%2FstgSyn%2FCoreToStg.lhs;h=9397af6c74d868d99cb5c681ebce0c445b61c99e;hb=ef5b4b146aa172d8ac10f39b5eb3d7a0f948d8f1;hp=61e67df57c1e923a30e7bf7e70df79572ae4a031;hpb=1f8b341a88b6b60935b0ce80b59ed6e356b8cfbf;p=ghc-hetmet.git

diff --git a/ghc/compiler/stgSyn/CoreToStg.lhs b/ghc/compiler/stgSyn/CoreToStg.lhs
index 61e67df..9397af6 100644
--- a/ghc/compiler/stgSyn/CoreToStg.lhs
+++ b/ghc/compiler/stgSyn/CoreToStg.lhs
@@ -142,7 +142,7 @@ for x, solely to put in the SRTs lower down.
 coreToStg :: DynFlags -> [CoreBind] -> IO [StgBinding]
 coreToStg dflags pgm
   = return pgm'
-  where (_, _, pgm') = coreTopBindsToStg emptyVarEnv pgm
+  where (_, _, pgm') = coreTopBindsToStg dflags emptyVarEnv pgm
 
 coreExprToStg :: CoreExpr -> StgExpr
 coreExprToStg expr 
@@ -150,33 +150,35 @@ coreExprToStg expr
 
 
 coreTopBindsToStg
-    :: IdEnv HowBound		-- environment for the bindings
+    :: DynFlags
+    -> IdEnv HowBound		-- environment for the bindings
     -> [CoreBind]
     -> (IdEnv HowBound, FreeVarsInfo, [StgBinding])
 
-coreTopBindsToStg env [] = (env, emptyFVInfo, [])
-coreTopBindsToStg env (b:bs)
+coreTopBindsToStg dflags env [] = (env, emptyFVInfo, [])
+coreTopBindsToStg dflags env (b:bs)
   = (env2, fvs2, b':bs')
   where
 	-- env accumulates down the list of binds, fvs accumulates upwards
-	(env1, fvs2, b' ) = coreTopBindToStg env fvs1 b
-  	(env2, fvs1, bs') = coreTopBindsToStg env1 bs
+	(env1, fvs2, b' ) = coreTopBindToStg dflags env fvs1 b
+  	(env2, fvs1, bs') = coreTopBindsToStg dflags env1 bs
 
 
 coreTopBindToStg
-	:: IdEnv HowBound
+	:: DynFlags
+	-> IdEnv HowBound
 	-> FreeVarsInfo		-- Info about the body
 	-> CoreBind
 	-> (IdEnv HowBound, FreeVarsInfo, StgBinding)
 
-coreTopBindToStg env body_fvs (NonRec id rhs)
+coreTopBindToStg dflags env body_fvs (NonRec id rhs)
   = let 
 	env' 	  = extendVarEnv env id how_bound
 	how_bound = LetBound TopLet (manifestArity rhs)
 
         (stg_rhs, fvs') = 
 	    initLne env (
-              coreToTopStgRhs body_fvs (id,rhs)	`thenLne` \ (stg_rhs, fvs') ->
+              coreToTopStgRhs dflags body_fvs (id,rhs)	`thenLne` \ (stg_rhs, fvs') ->
 	      returnLne (stg_rhs, fvs')
            )
 	
@@ -187,7 +189,7 @@ coreTopBindToStg env body_fvs (NonRec id rhs)
 --    WARN(not (consistent caf_info bind), ppr id <+> ppr cafs <+> ppCafInfo caf_info)
     (env', fvs' `unionFVInfo` body_fvs, bind)
 
-coreTopBindToStg env body_fvs (Rec pairs)
+coreTopBindToStg dflags env body_fvs (Rec pairs)
   = let 
 	(binders, rhss) = unzip pairs
 
@@ -197,7 +199,7 @@ coreTopBindToStg env body_fvs (Rec pairs)
 
         (stg_rhss, fvs')
 	  = initLne env' (
-	       mapAndUnzipLne (coreToTopStgRhs body_fvs) pairs
+	       mapAndUnzipLne (coreToTopStgRhs dflags body_fvs) pairs
 						`thenLne` \ (stg_rhss, fvss') ->
 	       let fvs' = unionFVInfos fvss' in
 	       returnLne (stg_rhss, fvs')
@@ -229,17 +231,18 @@ consistentCafInfo id bind
 
 \begin{code}
 coreToTopStgRhs
-	:: FreeVarsInfo		-- Free var info for the scope of the binding
+	:: DynFlags
+	-> FreeVarsInfo		-- Free var info for the scope of the binding
 	-> (Id,CoreExpr)
 	-> LneM (StgRhs, FreeVarsInfo)
 
-coreToTopStgRhs scope_fv_info (bndr, rhs)
+coreToTopStgRhs dflags scope_fv_info (bndr, rhs)
   = coreToStgExpr rhs 		`thenLne` \ (new_rhs, rhs_fvs, _) ->
     freeVarsToLiveVars rhs_fvs	`thenLne` \ lv_info ->
     returnLne (mkTopStgRhs is_static rhs_fvs (mkSRT lv_info) bndr_info new_rhs, rhs_fvs)
   where
     bndr_info = lookupFVInfo scope_fv_info bndr
-    is_static = rhsIsStatic rhs
+    is_static = rhsIsStatic dflags rhs
 
 mkTopStgRhs :: Bool -> FreeVarsInfo -> SRT -> StgBinderInfo -> StgExpr
 	-> StgRhs