X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FcoreSyn%2FCorePrep.lhs;h=738bf82bc66e205693d77fb4975fad80deec517a;hb=064812423073e89805c16311728cfded5d50e306;hp=b8dd80f703e66e55ddfc2ae624ba0767efdb38b1;hpb=62eeda5aed31173b234b2965ccf4bd6979ffd9a4;p=ghc-hetmet.git diff --git a/compiler/coreSyn/CorePrep.lhs b/compiler/coreSyn/CorePrep.lhs index b8dd80f..738bf82 100644 --- a/compiler/coreSyn/CorePrep.lhs +++ b/compiler/coreSyn/CorePrep.lhs @@ -11,15 +11,16 @@ module CorePrep ( #include "HsVersions.h" +import PrelNames ( lazyIdKey, hasKey ) import CoreUtils import CoreArity import CoreFVs -import CoreLint +import CoreMonad ( endPass ) import CoreSyn import Type import Coercion import TyCon -import NewDemand +import Demand import Var import VarSet import VarEnv @@ -85,10 +86,11 @@ The goal of this pass is to prepare for code generation. 8. Inject bindings for the "implicit" Ids: * Constructor wrappers * Constructor workers - * Record selectors We want curried definitions for all of these in case they aren't inlined by some caller. +9. Replace (lazy e) by e. See Note [lazyId magic] in MkId.lhs + This is all done modulo type applications and abstractions, so that when type erasure is done for conversion to STG, we don't end up with any trivial or useless bindings. @@ -145,7 +147,7 @@ corePrepPgm dflags binds data_tycons = do floats2 <- corePrepTopBinds implicit_binds return (deFloatTop (floats1 `appendFloats` floats2)) - endPass dflags "CorePrep" Opt_D_dump_prep binds_out + endPass dflags "CorePrep" Opt_D_dump_prep binds_out [] return binds_out corePrepExpr :: DynFlags -> CoreExpr -> IO CoreExpr @@ -242,7 +244,7 @@ cpeBind :: TopLevelFlag -> UniqSM (CorePrepEnv, Floats) cpeBind top_lvl env (NonRec bndr rhs) = do { (_, bndr1) <- cloneBndr env bndr - ; let is_strict = isStrictDmd (idNewDemandInfo bndr) + ; let is_strict = isStrictDmd (idDemandInfo bndr) is_unlifted = isUnLiftedType (idType bndr) ; (floats, bndr2, rhs2) <- cpePair top_lvl NonRecursive (is_strict || is_unlifted) @@ -277,35 +279,59 @@ cpePair :: TopLevelFlag -> RecFlag -> RhsDemand -> UniqSM (Floats, Id, CoreExpr) -- Used for all bindings cpePair top_lvl is_rec is_strict_or_unlifted env bndr rhs - = do { (floats, rhs') <- cpeRhs want_float (idArity bndr) env rhs + = do { (floats1, rhs1) <- cpeRhsE env rhs + ; let (rhs1_bndrs, _) = collectBinders rhs1 + ; (floats2, rhs2) + <- if want_float floats1 rhs1 + then return (floats1, rhs1) + else -- Non-empty floats will wrap rhs1 + -- But: rhs1 might have lambdas, and we can't + -- put them inside a wrapBinds + if valBndrCount rhs1_bndrs <= arity + then -- Lambdas in rhs1 will be nuked by eta expansion + return (emptyFloats, wrapBinds floats1 rhs1) + + else do { body1 <- rhsToBodyNF rhs1 + ; return (emptyFloats, wrapBinds floats1 body1) } + + ; (floats3, rhs') -- Note [Silly extra arguments] + <- if manifestArity rhs2 <= arity + then return (floats2, cpeEtaExpand arity rhs2) + else WARN(True, text "CorePrep: silly extra arguments:" <+> ppr bndr) + (do { v <- newVar (idType bndr) + ; let float = mkFloat False False v rhs2 + ; return (addFloat floats2 float, cpeEtaExpand arity (Var v)) }) -- Record if the binder is evaluated ; let bndr' | exprIsHNF rhs' = bndr `setIdUnfolding` evaldUnfolding | otherwise = bndr - ; return (floats, bndr', rhs') } + ; return (floats3, bndr', rhs') } where + arity = idArity bndr -- We must match this arity want_float floats rhs | isTopLevel top_lvl = wantFloatTop bndr floats | otherwise = wantFloatNested is_rec is_strict_or_unlifted floats rhs - +{- Note [Silly extra arguments] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we had this + f{arity=1} = \x\y. e +We *must* match the arity on the Id, so we have to generate + f' = \x\y. e + f = \x. f' x + +It's a bizarre case: why is the arity on the Id wrong? Reason +(in the days of __inline_me__): + f{arity=0} = __inline_me__ (let v = expensive in \xy. e) +When InlineMe notes go away this won't happen any more. But +it seems good for CorePrep to be robust. +-} -- --------------------------------------------------------------------------- -- CpeRhs: produces a result satisfying CpeRhs -- --------------------------------------------------------------------------- -cpeRhs :: (Floats -> CpeRhs -> Bool) -- Float the floats out - -> Arity -- Guarantees an Rhs with this manifest arity - -> CorePrepEnv - -> CoreExpr -- Expression and its type - -> UniqSM (Floats, CpeRhs) -cpeRhs want_float arity env expr - = do { (floats, rhs) <- cpeRhsE env expr - ; if want_float floats rhs - then return (floats, cpeEtaExpand arity rhs) - else return (emptyFloats, cpeEtaExpand arity (wrapBinds floats rhs)) } - cpeRhsE :: CorePrepEnv -> CoreExpr -> UniqSM (Floats, CpeRhs) -- If -- e ===> (bs, e') @@ -317,9 +343,14 @@ cpeRhsE :: CorePrepEnv -> CoreExpr -> UniqSM (Floats, CpeRhs) cpeRhsE _env expr@(Type _) = return (emptyFloats, expr) cpeRhsE _env expr@(Lit _) = return (emptyFloats, expr) -cpeRhsE env expr@(App {}) = cpeApp env expr cpeRhsE env expr@(Var {}) = cpeApp env expr +cpeRhsE env (Var f `App` _ `App` arg) + | f `hasKey` lazyIdKey -- Replace (lazy a) by a + = cpeRhsE env arg -- See Note [lazyId magic] in MkId + +cpeRhsE env expr@(App {}) = cpeApp env expr + cpeRhsE env (Let bind expr) = do { (env', new_binds) <- cpeBind NotTopLevel env bind ; (floats, body) <- cpeRhsE env' expr @@ -377,8 +408,13 @@ cpeBody env expr ; return (floats1 `appendFloats` floats2, body) } -------- +rhsToBodyNF :: CpeRhs -> UniqSM CpeBody +rhsToBodyNF rhs = do { (floats,body) <- rhsToBody rhs + ; return (wrapBinds floats body) } + +-------- rhsToBody :: CpeRhs -> UniqSM (Floats, CpeBody) --- Remove top level lambdas by let-bindinig +-- Remove top level lambdas by let-binding rhsToBody (Note n expr) -- You can get things like @@ -446,7 +482,7 @@ cpeApp env expr collect_args (App fun arg) depth = do { (fun',hd,fun_ty,floats,ss) <- collect_args fun (depth+1) - ; let + ; let (ss1, ss_rest) = case ss of (ss1:ss_rest) -> (ss1, ss_rest) [] -> (lazyDmd, []) @@ -461,7 +497,7 @@ cpeApp env expr ; let v2 = lookupCorePrepEnv env v1 ; return (Var v2, (Var v2, depth), idType v2, emptyFloats, stricts) } where - stricts = case idNewStrictness v of + stricts = case idStrictness v of StrictSig (DmdType _ demands _) | listLengthCmp demands depth /= GT -> demands -- length demands <= depth @@ -482,10 +518,10 @@ cpeApp env expr = collect_args fun depth -- They aren't used by the code generator -- N-variable fun, better let-bind it - -- ToDo: perhaps we can case-bind rather than let-bind this closure, - -- since it is sure to be evaluated. collect_args fun depth = do { (fun_floats, fun') <- cpeArg env True fun ty + -- The True says that it's sure to be evaluated, + -- so we'll end up case-binding it ; return (fun', (fun', depth), ty, fun_floats, []) } where ty = exprType fun @@ -498,14 +534,21 @@ 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 + | cpe_ExprIsTrivial arg -- Do not eta expand etc a trivial argument + = cpeBody env arg -- Must still do substitution though | otherwise - = do { (floats, arg') <- cpeRhs want_float - (exprArity arg) env arg + = 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 + ; return (emptyFloats, wrapBinds floats1 body1) } + -- Else case: arg1 might have lambdas, and we can't + -- put them inside a wrapBinds + ; v <- newVar arg_ty - ; let arg_float = mkFloat is_strict is_unlifted v arg' - ; return (addFloat floats arg_float, Var v) } + ; let arg3 = cpeEtaExpand (exprArity arg2) arg2 + arg_float = mkFloat is_strict is_unlifted v arg3 + ; return (addFloat floats2 arg_float, Var v) } where is_unlifted = isUnLiftedType arg_ty want_float = wantFloatNested NonRecursive (is_strict || is_unlifted) @@ -597,7 +640,6 @@ ignoreNote :: Note -> Bool -- want to get this: -- unzip = /\ab \xs. (__inline_me__ ...) a b xs ignoreNote (CoreNote _) = True -ignoreNote InlineMe = True ignoreNote _other = False @@ -748,6 +790,9 @@ mkFloat is_strict is_unlifted bndr rhs emptyFloats :: Floats emptyFloats = Floats OkToSpec nilOL +isEmptyFloats :: Floats -> Bool +isEmptyFloats (Floats _ bs) = isNilOL bs + wrapBinds :: Floats -> CoreExpr -> CoreExpr wrapBinds (Floats _ binds) body = foldrOL mk_bind body binds @@ -800,12 +845,14 @@ deFloatTop (Floats _ floats) ------------------------------------------- wantFloatTop :: Id -> Floats -> Bool -- Note [CafInfo and floating] -wantFloatTop bndr floats = mayHaveCafRefs (idCafInfo bndr) - && allLazyTop floats +wantFloatTop bndr floats = isEmptyFloats floats + || (mayHaveCafRefs (idCafInfo bndr) + && allLazyTop floats) wantFloatNested :: RecFlag -> Bool -> Floats -> CpeRhs -> Bool wantFloatNested is_rec strict_or_unlifted floats rhs - = strict_or_unlifted + = isEmptyFloats floats + || strict_or_unlifted || (allLazyNested is_rec floats && exprIsHNF rhs) -- Why the test for allLazyNested? -- v = f (x `divInt#` y)