X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FcoreSyn%2FCorePrep.lhs;h=2cfd880309f4e76c39cecd266f52a9dae389bed2;hb=c391db2339eaddbe21636206d8e9a2000c24b6be;hp=4db4c53d569f1dab58ccebec1dafc54f6ce13235;hpb=66413c79385a5b30a668e91789b8a334f6977ca9;p=ghc-hetmet.git diff --git a/compiler/coreSyn/CorePrep.lhs b/compiler/coreSyn/CorePrep.lhs index 4db4c53..2cfd880 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)