cmmTopCodeGen no longer takes DynFlags as an argument

[ghc-hetmet.git] / compiler / stgSyn / CoreToStg.lhs

diff --git a/compiler/stgSyn/CoreToStg.lhs b/compiler/stgSyn/CoreToStg.lhs
index 54895aa..df8fabe 100644 (file)
--- a/compiler/stgSyn/CoreToStg.lhs
+++ b/compiler/stgSyn/CoreToStg.lhs
@@ -18,8 +18,8 @@ import StgSyn
 
 import Type
 import TyCon
+import MkId            ( coercionTokenId )
 import Id
-import Var              ( Var )
 import IdInfo
 import DataCon
 import CostCentre       ( noCCS )
@@ -218,7 +218,7 @@ coreTopBindToStg this_pkg env body_fvs (Rec pairs)
 -- floated out a binding, in which case it will be approximate.
 consistentCafInfo :: Id -> GenStgBinding Var Id -> Bool
 consistentCafInfo id bind
-  = WARN( not (exact || is_sat_thing) , ppr id )
+  = WARN( not (exact || is_sat_thing) , ppr id <+> ppr id_marked_caffy <+> ppr binding_is_caffy )
     safe
   where
     safe  = id_marked_caffy || not binding_is_caffy
@@ -312,8 +312,9 @@ on these components, but it in turn is not scrutinised as the basis for any
 decisions.  Hence no black holes.
 
 \begin{code}
-coreToStgExpr (Lit l) = return (StgLit l, emptyFVInfo, emptyVarSet)
-coreToStgExpr (Var v) = coreToStgApp Nothing v []
+coreToStgExpr (Lit l)      = return (StgLit l, emptyFVInfo, emptyVarSet)
+coreToStgExpr (Var v)      = coreToStgApp Nothing v               []
+coreToStgExpr (Coercion _) = coreToStgApp Nothing coercionTokenId []
 
 coreToStgExpr expr@(App _ _)
   = coreToStgApp Nothing f args
@@ -544,13 +545,17 @@ coreToStgApp _ f args = do
 
                 TickBoxOpId {}   -> pprPanic "coreToStg TickBox" $ ppr (f,args')
                 _other           -> StgApp f args'
-
-    return (
-        app,
-        fun_fvs  `unionFVInfo` args_fvs,
-        fun_escs `unionVarSet` (getFVSet args_fvs)
+        fvs = fun_fvs  `unionFVInfo` args_fvs
+        vars = fun_escs `unionVarSet` (getFVSet args_fvs)
                                 -- All the free vars of the args are disqualified
                                 -- from being let-no-escaped.
+
+    -- Forcing these fixes a leak in the code generator, noticed while
+    -- profiling for trac #4367
+    app `seq` fvs `seq` seqVarSet vars `seq` return (
+        app,
+        fvs,
+        vars
      )
 
 
@@ -568,6 +573,10 @@ coreToStgArgs (Type _ : args) = do     -- Type argument
     (args', fvs) <- coreToStgArgs args
     return (args', fvs)
 
+coreToStgArgs (Coercion _ : args)  -- Coercion argument; replace with place holder
+  = do { (args', fvs) <- coreToStgArgs args
+       ; return (StgVarArg coercionTokenId : args', fvs) }
+
 coreToStgArgs (arg : args) = do         -- Non-type argument
     (stg_args, args_fvs) <- coreToStgArgs args
     (arg', arg_fvs, _escs) <- coreToStgExpr arg
@@ -770,7 +779,7 @@ mkStgRhs rhs_fvs srt binder_info rhs
     assumptions (namely that they will be entered only once).
 
     upd_flag | isPAP env rhs  = ReEntrant
-             | otherwise      = Updatable
+            | otherwise      = Updatable
   -}
 
 {- ToDo:
@@ -1120,7 +1129,7 @@ myCollectArgs expr
     go (Cast e _)       as = go e as
     go (Note _ e)       as = go e as
     go (Lam b e)        as
-       | isTyCoVar b         = go e as  -- Note [Collect args]
+       | isTyVar b         = go e as  -- Note [Collect args]
     go _                _  = pprPanic "CoreToStg.myCollectArgs" (ppr expr)
 \end{code}