X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FcoreSyn%2FCorePrep.lhs;h=42379b4c0141763505586553ab6ff1cfff5ce369;hb=b6264a6b8a8e22e24464da39ca0a3a0176d91f4e;hp=2cfd880309f4e76c39cecd266f52a9dae389bed2;hpb=c391db2339eaddbe21636206d8e9a2000c24b6be;p=ghc-hetmet.git

diff --git a/compiler/coreSyn/CorePrep.lhs b/compiler/coreSyn/CorePrep.lhs
index 2cfd880..42379b4 100644
--- a/compiler/coreSyn/CorePrep.lhs
+++ b/compiler/coreSyn/CorePrep.lhs
@@ -18,6 +18,7 @@ import CoreFVs
 import CoreMonad	( endPass, CoreToDo(..) )
 import CoreSyn
 import CoreSubst
+import OccurAnal        ( occurAnalyseExpr )
 import Type
 import Coercion
 import TyCon
@@ -248,6 +249,61 @@ always fully applied, and the bindings are just there to support
 partial applications. But it's easier to let them through.
 
 
+Note [Dead code in CorePrep]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Imagine that we got an input program like this:
+
+  f :: Show b => Int -> (Int, b -> Maybe Int -> Int)
+  f x = (g True (Just x) + g () (Just x), g)
+    where
+      g :: Show a => a -> Maybe Int -> Int
+      g _ Nothing = x
+      g y (Just z) = if z > 100 then g y (Just (z + length (show y))) else g y unknown
+
+After specialisation and SpecConstr, we would get something like this:
+
+  f :: Show b => Int -> (Int, b -> Maybe Int -> Int)
+  f x = (g$Bool_True_Just x + g$Unit_Unit_Just x, g)
+    where
+      {-# RULES g $dBool = g$Bool 
+                g $dUnit = g$Unit #-}
+      g = ...
+      {-# RULES forall x. g$Bool True (Just x) = g$Bool_True_Just x #-}
+      g$Bool = ...
+      {-# RULES forall x. g$Unit () (Just x) = g$Unit_Unit_Just x #-}
+      g$Unit = ...
+      g$Bool_True_Just = ...
+      g$Unit_Unit_Just = ...
+
+Note that the g$Bool and g$Unit functions are actually dead code: they are only kept
+alive by the occurrence analyser because they are referred to by the rules of g,
+which is being kept alive by the fact that it is used (unspecialised) in the returned pair.
+
+However, at the CorePrep stage there is no way that the rules for g will ever fire,
+and it really seems like a shame to produce an output program that goes to the trouble
+of allocating a closure for the unreachable g$Bool and g$Unit functions.
+
+The way we fix this is to:
+ * In cloneBndr, drop all unfoldings/rules
+ * In deFloatTop, run the occurrence analyser on each top-level RHS to drop
+   the dead local bindings
+
+The reason we don't just OccAnal the whole output of CorePrep is that the tidier
+ensures that all top-level binders are GlobalIds, so they don't show up in the free
+variables any longer. So if you run the occurrence analyser on the output of CoreTidy
+(or later) you e.g. turn this program:
+
+  Rec {
+  f = ... f ...
+  }
+
+Into this one:
+
+  f = ... f ...
+
+(Since f is not considered to be free in its own RHS.)
+
+
 %************************************************************************
 %*									*
 		The main code
@@ -637,9 +693,7 @@ maybeSaturate fn expr n_args
 
 -------------
 saturateDataToTag :: CpeApp -> UniqSM CpeApp
--- Horrid: ensure that the arg of data2TagOp is evaluated
---   (data2tag x) -->  (case x of y -> data2tag y)
--- (yuk yuk) take into account the lambdas we've now introduced
+-- See Note [dataToTag magic]
 saturateDataToTag sat_expr
   = do { let (eta_bndrs, eta_body) = collectBinders sat_expr
        ; eta_body' <- eval_data2tag_arg eta_body
@@ -663,7 +717,14 @@ saturateDataToTag sat_expr
 	= pprPanic "eval_data2tag" (ppr other)
 \end{code}
 
+Note [dataToTag magic]
+~~~~~~~~~~~~~~~~~~~~~~
+Horrid: we must ensure that the arg of data2TagOp is evaluated
+  (data2tag x) -->  (case x of y -> data2tag y)
+(yuk yuk) take into account the lambdas we've now introduced
 
+How might it not be evaluated?  Well, we might have floated it out
+of the scope of a `seq`, or dropped the `seq` altogether.
 
 
 %************************************************************************
@@ -896,8 +957,12 @@ deFloatTop :: Floats -> [CoreBind]
 deFloatTop (Floats _ floats)
   = foldrOL get [] floats
   where
-    get (FloatLet b) bs = b:bs
+    get (FloatLet b) bs = occurAnalyseRHSs b : bs
     get b            _  = pprPanic "corePrepPgm" (ppr b)
+    
+    -- See Note [Dead code in CorePrep]
+    occurAnalyseRHSs (NonRec x e) = NonRec x (occurAnalyseExpr e)
+    occurAnalyseRHSs (Rec xes)    = Rec [(x, occurAnalyseExpr e) | (x, e) <- xes]
 
 -------------------------------------------
 canFloatFromNoCaf ::  Floats -> CpeRhs -> Maybe (Floats, CpeRhs)
@@ -1007,7 +1072,13 @@ cloneBndr  :: CorePrepEnv -> Var -> UniqSM (CorePrepEnv, Var)
 cloneBndr env bndr
   | isLocalId bndr
   = do bndr' <- setVarUnique bndr <$> getUniqueM
-       return (extendCorePrepEnv env bndr bndr', bndr')
+       
+       -- We are going to OccAnal soon, so drop (now-useless) rules/unfoldings
+       -- so that we can drop more stuff as dead code.
+       -- See also Note [Dead code in CorePrep]
+       let bndr'' = bndr' `setIdUnfolding` noUnfolding
+                          `setIdSpecialisation` emptySpecInfo
+       return (extendCorePrepEnv env bndr bndr'', bndr'')
 
   | otherwise	-- Top level things, which we don't want
 		-- to clone, have become GlobalIds by now