X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FcoreSyn%2FCorePrep.lhs;h=540fa2de3237dc6ca692333f946d058e907dcce2;hp=ef5e75e54432e286772a6c0a070dee19a803105b;hb=c406b5bde899dd2b28e5239937c909d675bca356;hpb=9e6ca39b5e90b7a4acc755e3e95cc3ef60940070

diff --git a/compiler/coreSyn/CorePrep.lhs b/compiler/coreSyn/CorePrep.lhs
index ef5e75e..540fa2d 100644
--- a/compiler/coreSyn/CorePrep.lhs
+++ b/compiler/coreSyn/CorePrep.lhs
@@ -278,7 +278,7 @@ cpeBind top_lvl env (Rec pairs)
        ; stuff <- zipWithM (cpePair top_lvl Recursive False env') bndrs1 rhss
 
        ; let (floats_s, bndrs2, rhss2) = unzip3 stuff
-             all_pairs = foldrOL add_float (bndrs1 `zip` rhss2)
+             all_pairs = foldrOL add_float (bndrs2 `zip` rhss2)
 	     	       	 	 	   (concatFloats floats_s)
        ; return (extendCorePrepEnvList env (bndrs `zip` bndrs2),
        	 	 unitFloat (FloatLet (Rec all_pairs))) }
@@ -310,9 +310,13 @@ cpePair top_lvl is_rec is_strict_or_unlifted env bndr rhs
 		        ; let float = mkFloat False False v rhs2
 		        ; return (addFloat floats2 float, cpeEtaExpand arity (Var v)) })
 
-	     	-- Record if the binder is evaluated
+     	-- Record if the binder is evaluated
+	-- and otherwise trim off the unfolding altogether
+	-- It's not used by the code generator; getting rid of it reduces
+	-- heap usage and, since we may be changing uniques, we'd have
+	-- to substitute to keep it right
        ; let bndr' | exprIsHNF rhs' = bndr `setIdUnfolding` evaldUnfolding
-       	     	   | otherwise      = bndr
+       	     	   | otherwise      = bndr `setIdUnfolding` noUnfolding
 
        ; return (floats3, bndr', rhs') }
   where
@@ -573,10 +577,7 @@ cpeApp env expr
 cpeArg :: CorePrepEnv -> RhsDemand -> CoreArg -> Type
        -> UniqSM (Floats, CpeTriv)
 cpeArg env is_strict arg arg_ty
-  | cpe_ExprIsTrivial arg   -- Do not eta expand etc a trivial argument
-  = cpeBody env arg	    -- Must still do substitution though
-  | otherwise
-  = do { (floats1, arg1) <- cpeRhsE env arg	-- arg1 can be a lambda
+  = do { (floats1, arg1) <- cpeRhsE env arg     -- arg1 can be a lambda
        ; (floats2, arg2) <- if want_float floats1 arg1 
        	 	   	    then return (floats1, arg1)
        	 	   	    else do { body1 <- rhsToBodyNF arg1
@@ -584,10 +585,13 @@ cpeArg env is_strict arg arg_ty
 	 	-- Else case: arg1 might have lambdas, and we can't
 		--            put them inside a wrapBinds
 
-       ; v <- newVar arg_ty
+       ; if cpe_ExprIsTrivial arg2    -- Do not eta expand a trivial argument
+         then return (floats2, arg2)
+         else do
+       { v <- newVar arg_ty
        ; let arg3      = cpeEtaExpand (exprArity arg2) arg2
        	     arg_float = mkFloat is_strict is_unlifted v arg3
-       ; return (addFloat floats2 arg_float, Var v) }
+       ; return (addFloat floats2 arg_float, Var v) } }
   where
     is_unlifted = isUnLiftedType arg_ty
     want_float = wantFloatNested NonRecursive (is_strict || is_unlifted)
@@ -633,9 +637,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
@@ -659,7 +661,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.
 
 
 %************************************************************************
@@ -688,8 +697,7 @@ cpe_ExprIsTrivial (Var _)                  = True
 cpe_ExprIsTrivial (Type _)                 = True
 cpe_ExprIsTrivial (Lit _)                  = True
 cpe_ExprIsTrivial (App e arg)              = isTypeArg arg && cpe_ExprIsTrivial e
-cpe_ExprIsTrivial (Note (SCC _) _)         = False
-cpe_ExprIsTrivial (Note _ e)               = cpe_ExprIsTrivial e
+cpe_ExprIsTrivial (Note n e)               = notSccNote n  && cpe_ExprIsTrivial e
 cpe_ExprIsTrivial (Cast e _)               = cpe_ExprIsTrivial e
 cpe_ExprIsTrivial (Lam b body) | isTyCoVar b = cpe_ExprIsTrivial body
 cpe_ExprIsTrivial _                        = False