diff options
Diffstat (limited to 'compiler/coreSyn/CorePrep.lhs')
| -rw-r--r-- | compiler/coreSyn/CorePrep.lhs | 859 |
1 files changed, 859 insertions, 0 deletions
diff --git a/compiler/coreSyn/CorePrep.lhs b/compiler/coreSyn/CorePrep.lhs new file mode 100644 index 0000000000..e5165f0ebe --- /dev/null +++ b/compiler/coreSyn/CorePrep.lhs @@ -0,0 +1,859 @@ +% +% (c) The University of Glasgow, 1994-2000 +% +\section{Core pass to saturate constructors and PrimOps} + +\begin{code} +module CorePrep ( + corePrepPgm, corePrepExpr + ) where + +#include "HsVersions.h" + +import CoreUtils( exprType, exprIsHNF, etaExpand, exprArity, exprOkForSpeculation ) +import CoreFVs ( exprFreeVars ) +import CoreLint ( endPass ) +import CoreSyn +import Type ( Type, applyTy, splitFunTy_maybe, + isUnLiftedType, isUnboxedTupleType, seqType ) +import TyCon ( TyCon, tyConDataCons ) +import NewDemand ( Demand, isStrictDmd, lazyDmd, StrictSig(..), DmdType(..) ) +import Var ( Var, Id, setVarUnique ) +import VarSet +import VarEnv +import Id ( mkSysLocal, idType, idNewDemandInfo, idArity, setIdUnfolding, setIdType, + isFCallId, isGlobalId, + isLocalId, hasNoBinding, idNewStrictness, + isPrimOpId_maybe + ) +import DataCon ( isVanillaDataCon, dataConWorkId ) +import PrimOp ( PrimOp( DataToTagOp ) ) +import BasicTypes ( TopLevelFlag(..), isTopLevel, isNotTopLevel, + RecFlag(..), isNonRec + ) +import UniqSupply +import Maybes +import OrdList +import ErrUtils +import DynFlags +import Util ( listLengthCmp ) +import Outputable +\end{code} + +-- --------------------------------------------------------------------------- +-- Overview +-- --------------------------------------------------------------------------- + +The goal of this pass is to prepare for code generation. + +1. Saturate constructor and primop applications. + +2. Convert to A-normal form: + + * Use case for strict arguments: + f E ==> case E of x -> f x + (where f is strict) + + * Use let for non-trivial lazy arguments + f E ==> let x = E in f x + (were f is lazy and x is non-trivial) + +3. Similarly, convert any unboxed lets into cases. + [I'm experimenting with leaving 'ok-for-speculation' + rhss in let-form right up to this point.] + +4. Ensure that lambdas only occur as the RHS of a binding + (The code generator can't deal with anything else.) + +5. [Not any more; nuked Jun 2002] Do the seq/par munging. + +6. Clone all local Ids. + This means that all such Ids are unique, rather than the + weaker guarantee of no clashes which the simplifier provides. + And that is what the code generator needs. + + We don't clone TyVars. The code gen doesn't need that, + and doing so would be tiresome because then we'd need + to substitute in types. + + +7. Give each dynamic CCall occurrence a fresh unique; this is + rather like the cloning step above. + +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. + +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. + + + +-- ----------------------------------------------------------------------------- +-- Top level stuff +-- ----------------------------------------------------------------------------- + +\begin{code} +corePrepPgm :: DynFlags -> [CoreBind] -> [TyCon] -> IO [CoreBind] +corePrepPgm dflags binds data_tycons + = do showPass dflags "CorePrep" + us <- mkSplitUniqSupply 's' + + let implicit_binds = mkDataConWorkers data_tycons + -- NB: we must feed mkImplicitBinds through corePrep too + -- so that they are suitably cloned and eta-expanded + + binds_out = initUs_ us ( + corePrepTopBinds binds `thenUs` \ floats1 -> + corePrepTopBinds implicit_binds `thenUs` \ floats2 -> + returnUs (deFloatTop (floats1 `appendFloats` floats2)) + ) + + endPass dflags "CorePrep" Opt_D_dump_prep binds_out + return binds_out + +corePrepExpr :: DynFlags -> CoreExpr -> IO CoreExpr +corePrepExpr dflags expr + = do showPass dflags "CorePrep" + us <- mkSplitUniqSupply 's' + let new_expr = initUs_ us (corePrepAnExpr emptyCorePrepEnv expr) + dumpIfSet_dyn dflags Opt_D_dump_prep "CorePrep" + (ppr new_expr) + return new_expr +\end{code} + +-- ----------------------------------------------------------------------------- +-- Implicit bindings +-- ----------------------------------------------------------------------------- + +Create any necessary "implicit" bindings for data con workers. We +create the rather strange (non-recursive!) binding + + $wC = \x y -> $wC x y + +i.e. a curried constructor that allocates. This means that we can +treat the worker for a constructor like any other function in the rest +of the compiler. The point here is that CoreToStg will generate a +StgConApp for the RHS, rather than a call to the worker (which would +give a loop). As Lennart says: the ice is thin here, but it works. + +Hmm. Should we create bindings for dictionary constructors? They are +always fully applied, and the bindings are just there to support +partial applications. But it's easier to let them through. + +\begin{code} +mkDataConWorkers data_tycons + = [ NonRec id (Var id) -- The ice is thin here, but it works + | tycon <- data_tycons, -- CorePrep will eta-expand it + data_con <- tyConDataCons tycon, + let id = dataConWorkId data_con ] +\end{code} + + +\begin{code} +-- --------------------------------------------------------------------------- +-- Dealing with bindings +-- --------------------------------------------------------------------------- + +data FloatingBind = FloatLet CoreBind + | FloatCase Id CoreExpr Bool + -- The bool indicates "ok-for-speculation" + +data Floats = Floats OkToSpec (OrdList FloatingBind) + +-- Can we float these binds out of the rhs of a let? We cache this decision +-- to avoid having to recompute it in a non-linear way when there are +-- deeply nested lets. +data OkToSpec + = NotOkToSpec -- definitely not + | OkToSpec -- yes + | IfUnboxedOk -- only if floating an unboxed binding is ok + +emptyFloats :: Floats +emptyFloats = Floats OkToSpec nilOL + +addFloat :: Floats -> FloatingBind -> Floats +addFloat (Floats ok_to_spec floats) new_float + = Floats (combine ok_to_spec (check new_float)) (floats `snocOL` new_float) + where + check (FloatLet _) = OkToSpec + check (FloatCase _ _ ok_for_spec) + | ok_for_spec = IfUnboxedOk + | otherwise = NotOkToSpec + -- The ok-for-speculation flag says that it's safe to + -- float this Case out of a let, and thereby do it more eagerly + -- We need the top-level flag because it's never ok to float + -- an unboxed binding to the top level + +unitFloat :: FloatingBind -> Floats +unitFloat = addFloat emptyFloats + +appendFloats :: Floats -> Floats -> Floats +appendFloats (Floats spec1 floats1) (Floats spec2 floats2) + = Floats (combine spec1 spec2) (floats1 `appOL` floats2) + +concatFloats :: [Floats] -> Floats +concatFloats = foldr appendFloats emptyFloats + +combine NotOkToSpec _ = NotOkToSpec +combine _ NotOkToSpec = NotOkToSpec +combine IfUnboxedOk _ = IfUnboxedOk +combine _ IfUnboxedOk = IfUnboxedOk +combine _ _ = OkToSpec + +instance Outputable FloatingBind where + ppr (FloatLet bind) = text "FloatLet" <+> ppr bind + ppr (FloatCase b rhs spec) = text "FloatCase" <+> ppr b <+> ppr spec <+> equals <+> ppr rhs + +deFloatTop :: Floats -> [CoreBind] +-- For top level only; we don't expect any FloatCases +deFloatTop (Floats _ floats) + = foldrOL get [] floats + where + get (FloatLet b) bs = b:bs + get b bs = pprPanic "corePrepPgm" (ppr b) + +allLazy :: TopLevelFlag -> RecFlag -> Floats -> Bool +allLazy top_lvl is_rec (Floats ok_to_spec _) + = case ok_to_spec of + OkToSpec -> True + NotOkToSpec -> False + IfUnboxedOk -> isNotTopLevel top_lvl && isNonRec is_rec + +-- --------------------------------------------------------------------------- +-- Bindings +-- --------------------------------------------------------------------------- + +corePrepTopBinds :: [CoreBind] -> UniqSM Floats +corePrepTopBinds binds + = go emptyCorePrepEnv binds + where + go env [] = returnUs emptyFloats + go env (bind : binds) = corePrepTopBind env bind `thenUs` \ (env', bind') -> + go env' binds `thenUs` \ binds' -> + returnUs (bind' `appendFloats` binds') + +-- NB: we do need to float out of top-level bindings +-- Consider x = length [True,False] +-- We want to get +-- s1 = False : [] +-- s2 = True : s1 +-- x = length s2 + +-- We return a *list* of bindings, because we may start with +-- x* = f (g y) +-- where x is demanded, in which case we want to finish with +-- a = g y +-- x* = f a +-- And then x will actually end up case-bound +-- +-- What happens to the CafInfo on the floated bindings? By +-- default, all the CafInfos will be set to MayHaveCafRefs, +-- which is safe. +-- +-- This might be pessimistic, because eg. s1 & s2 +-- might not refer to any CAFs and the GC will end up doing +-- more traversal than is necessary, but it's still better +-- than not floating the bindings at all, because then +-- the GC would have to traverse the structure in the heap +-- instead. Given this, we decided not to try to get +-- the CafInfo on the floated bindings correct, because +-- it looks difficult. + +-------------------------------- +corePrepTopBind :: CorePrepEnv -> CoreBind -> UniqSM (CorePrepEnv, Floats) +corePrepTopBind env (NonRec bndr rhs) + = cloneBndr env bndr `thenUs` \ (env', bndr') -> + corePrepRhs TopLevel NonRecursive env (bndr, rhs) `thenUs` \ (floats, rhs') -> + returnUs (env', addFloat floats (FloatLet (NonRec bndr' rhs'))) + +corePrepTopBind env (Rec pairs) = corePrepRecPairs TopLevel env pairs + +-------------------------------- +corePrepBind :: CorePrepEnv -> CoreBind -> UniqSM (CorePrepEnv, Floats) + -- This one is used for *local* bindings +corePrepBind env (NonRec bndr rhs) + = etaExpandRhs bndr rhs `thenUs` \ rhs1 -> + corePrepExprFloat env rhs1 `thenUs` \ (floats, rhs2) -> + cloneBndr env bndr `thenUs` \ (_, bndr') -> + mkLocalNonRec bndr' (bdrDem bndr) floats rhs2 `thenUs` \ (floats', bndr'') -> + -- We want bndr'' in the envt, because it records + -- the evaluated-ness of the binder + returnUs (extendCorePrepEnv env bndr bndr'', floats') + +corePrepBind env (Rec pairs) = corePrepRecPairs NotTopLevel env pairs + +-------------------------------- +corePrepRecPairs :: TopLevelFlag -> CorePrepEnv + -> [(Id,CoreExpr)] -- Recursive bindings + -> UniqSM (CorePrepEnv, Floats) +-- Used for all recursive bindings, top level and otherwise +corePrepRecPairs lvl env pairs + = cloneBndrs env (map fst pairs) `thenUs` \ (env', bndrs') -> + mapAndUnzipUs (corePrepRhs lvl Recursive env') pairs `thenUs` \ (floats_s, rhss') -> + returnUs (env', unitFloat (FloatLet (Rec (flatten (concatFloats floats_s) bndrs' rhss')))) + where + -- Flatten all the floats, and the currrent + -- group into a single giant Rec + flatten (Floats _ floats) bndrs rhss = foldrOL get (bndrs `zip` rhss) floats + + get (FloatLet (NonRec b r)) prs2 = (b,r) : prs2 + get (FloatLet (Rec prs1)) prs2 = prs1 ++ prs2 + get b prs2 = pprPanic "corePrepRecPairs" (ppr b) + +-------------------------------- +corePrepRhs :: TopLevelFlag -> RecFlag + -> CorePrepEnv -> (Id, CoreExpr) + -> UniqSM (Floats, CoreExpr) +-- Used for top-level bindings, and local recursive bindings +corePrepRhs top_lvl is_rec env (bndr, rhs) + = etaExpandRhs bndr rhs `thenUs` \ rhs' -> + corePrepExprFloat env rhs' `thenUs` \ floats_w_rhs -> + floatRhs top_lvl is_rec bndr floats_w_rhs + + +-- --------------------------------------------------------------------------- +-- Making arguments atomic (function args & constructor args) +-- --------------------------------------------------------------------------- + +-- This is where we arrange that a non-trivial argument is let-bound +corePrepArg :: CorePrepEnv -> CoreArg -> RhsDemand + -> UniqSM (Floats, CoreArg) +corePrepArg env arg dem + = corePrepExprFloat env arg `thenUs` \ (floats, arg') -> + if exprIsTrivial arg' + then returnUs (floats, arg') + else newVar (exprType arg') `thenUs` \ v -> + mkLocalNonRec v dem floats arg' `thenUs` \ (floats', v') -> + returnUs (floats', Var v') + +-- version that doesn't consider an scc annotation to be trivial. +exprIsTrivial (Var v) = True +exprIsTrivial (Type _) = True +exprIsTrivial (Lit lit) = True +exprIsTrivial (App e arg) = isTypeArg arg && exprIsTrivial e +exprIsTrivial (Note (SCC _) e) = False +exprIsTrivial (Note _ e) = exprIsTrivial e +exprIsTrivial (Lam b body) | isTyVar b = exprIsTrivial body +exprIsTrivial other = False + +-- --------------------------------------------------------------------------- +-- Dealing with expressions +-- --------------------------------------------------------------------------- + +corePrepAnExpr :: CorePrepEnv -> CoreExpr -> UniqSM CoreExpr +corePrepAnExpr env expr + = corePrepExprFloat env expr `thenUs` \ (floats, expr) -> + mkBinds floats expr + + +corePrepExprFloat :: CorePrepEnv -> CoreExpr -> UniqSM (Floats, CoreExpr) +-- If +-- e ===> (bs, e') +-- then +-- e = let bs in e' (semantically, that is!) +-- +-- For example +-- f (g x) ===> ([v = g x], f v) + +corePrepExprFloat env (Var v) + = fiddleCCall v `thenUs` \ v1 -> + let + v2 = lookupCorePrepEnv env v1 + in + maybeSaturate v2 (Var v2) 0 emptyFloats (idType v2) + +corePrepExprFloat env expr@(Type _) + = returnUs (emptyFloats, expr) + +corePrepExprFloat env expr@(Lit lit) + = returnUs (emptyFloats, expr) + +corePrepExprFloat env (Let bind body) + = corePrepBind env bind `thenUs` \ (env', new_binds) -> + corePrepExprFloat env' body `thenUs` \ (floats, new_body) -> + returnUs (new_binds `appendFloats` floats, new_body) + +corePrepExprFloat env (Note n@(SCC _) expr) + = corePrepAnExpr env expr `thenUs` \ expr1 -> + deLamFloat expr1 `thenUs` \ (floats, expr2) -> + returnUs (floats, Note n expr2) + +corePrepExprFloat env (Note other_note expr) + = corePrepExprFloat env expr `thenUs` \ (floats, expr') -> + returnUs (floats, Note other_note expr') + +corePrepExprFloat env expr@(Lam _ _) + = cloneBndrs env bndrs `thenUs` \ (env', bndrs') -> + corePrepAnExpr env' body `thenUs` \ body' -> + returnUs (emptyFloats, mkLams bndrs' body') + where + (bndrs,body) = collectBinders expr + +corePrepExprFloat env (Case scrut bndr ty alts) + = corePrepExprFloat env scrut `thenUs` \ (floats1, scrut1) -> + deLamFloat scrut1 `thenUs` \ (floats2, scrut2) -> + let + bndr1 = bndr `setIdUnfolding` evaldUnfolding + -- Record that the case binder is evaluated in the alternatives + in + cloneBndr env bndr1 `thenUs` \ (env', bndr2) -> + mapUs (sat_alt env') alts `thenUs` \ alts' -> + returnUs (floats1 `appendFloats` floats2 , Case scrut2 bndr2 ty alts') + where + sat_alt env (con, bs, rhs) + = let + env1 = setGadt env con + in + cloneBndrs env1 bs `thenUs` \ (env2, bs') -> + corePrepAnExpr env2 rhs `thenUs` \ rhs1 -> + deLam rhs1 `thenUs` \ rhs2 -> + returnUs (con, bs', rhs2) + +corePrepExprFloat env expr@(App _ _) + = collect_args expr 0 `thenUs` \ (app, (head,depth), ty, floats, ss) -> + ASSERT(null ss) -- make sure we used all the strictness info + + -- Now deal with the function + case head of + Var fn_id -> maybeSaturate fn_id app depth floats ty + _other -> returnUs (floats, app) + + where + + -- Deconstruct and rebuild the application, floating any non-atomic + -- arguments to the outside. We collect the type of the expression, + -- the head of the application, and the number of actual value arguments, + -- all of which are used to possibly saturate this application if it + -- has a constructor or primop at the head. + + collect_args + :: CoreExpr + -> Int -- current app depth + -> UniqSM (CoreExpr, -- the rebuilt expression + (CoreExpr,Int), -- the head of the application, + -- and no. of args it was applied to + Type, -- type of the whole expr + Floats, -- any floats we pulled out + [Demand]) -- remaining argument demands + + collect_args (App fun arg@(Type arg_ty)) depth + = collect_args fun depth `thenUs` \ (fun',hd,fun_ty,floats,ss) -> + returnUs (App fun' arg, hd, applyTy fun_ty arg_ty, floats, ss) + + collect_args (App fun arg) depth + = collect_args fun (depth+1) `thenUs` \ (fun',hd,fun_ty,floats,ss) -> + let + (ss1, ss_rest) = case ss of + (ss1:ss_rest) -> (ss1, ss_rest) + [] -> (lazyDmd, []) + (arg_ty, res_ty) = expectJust "corePrepExprFloat:collect_args" $ + splitFunTy_maybe fun_ty + in + corePrepArg env arg (mkDemTy ss1 arg_ty) `thenUs` \ (fs, arg') -> + returnUs (App fun' arg', hd, res_ty, fs `appendFloats` floats, ss_rest) + + collect_args (Var v) depth + = fiddleCCall v `thenUs` \ v1 -> + let + v2 = lookupCorePrepEnv env v1 + in + returnUs (Var v2, (Var v2, depth), idType v2, emptyFloats, stricts) + where + stricts = case idNewStrictness v of + StrictSig (DmdType _ demands _) + | listLengthCmp demands depth /= GT -> demands + -- length demands <= depth + | otherwise -> [] + -- If depth < length demands, then we have too few args to + -- satisfy strictness info so we have to ignore all the + -- strictness info, e.g. + (error "urk") + -- Here, we can't evaluate the arg strictly, because this + -- partial application might be seq'd + + + collect_args (Note (Coerce ty1 ty2) fun) depth + = collect_args fun depth `thenUs` \ (fun', hd, fun_ty, floats, ss) -> + returnUs (Note (Coerce ty1 ty2) fun', hd, ty1, floats, ss) + + collect_args (Note note fun) depth + | ignore_note note -- Drop these notes altogether + -- They aren't used by the code generator + = collect_args fun depth `thenUs` \ (fun', hd, fun_ty, floats, ss) -> + returnUs (fun', hd, fun_ty, floats, ss) + + -- 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 + = corePrepExprFloat env fun `thenUs` \ (fun_floats, fun') -> + newVar ty `thenUs` \ fn_id -> + mkLocalNonRec fn_id onceDem fun_floats fun' `thenUs` \ (floats, fn_id') -> + returnUs (Var fn_id', (Var fn_id', depth), ty, floats, []) + where + ty = exprType fun + + ignore_note (CoreNote _) = True + ignore_note InlineCall = True + ignore_note InlineMe = True + ignore_note _other = False + -- We don't ignore SCCs, since they require some code generation + +------------------------------------------------------------------------------ +-- Building the saturated syntax +-- --------------------------------------------------------------------------- + +-- maybeSaturate deals with saturating primops and constructors +-- The type is the type of the entire application +maybeSaturate :: Id -> CoreExpr -> Int -> Floats -> Type -> UniqSM (Floats, CoreExpr) +maybeSaturate fn expr n_args floats ty + | Just DataToTagOp <- isPrimOpId_maybe fn -- DataToTag must have an evaluated arg + -- A gruesome special case + = saturate_it `thenUs` \ sat_expr -> + + -- OK, now ensure that the arg is evaluated. + -- But (sigh) take into account the lambdas we've now introduced + let + (eta_bndrs, eta_body) = collectBinders sat_expr + in + eval_data2tag_arg eta_body `thenUs` \ (eta_floats, eta_body') -> + if null eta_bndrs then + returnUs (floats `appendFloats` eta_floats, eta_body') + else + mkBinds eta_floats eta_body' `thenUs` \ eta_body'' -> + returnUs (floats, mkLams eta_bndrs eta_body'') + + | hasNoBinding fn = saturate_it `thenUs` \ sat_expr -> + returnUs (floats, sat_expr) + + | otherwise = returnUs (floats, expr) + + where + fn_arity = idArity fn + excess_arity = fn_arity - n_args + + saturate_it :: UniqSM CoreExpr + saturate_it | excess_arity == 0 = returnUs expr + | otherwise = getUniquesUs `thenUs` \ us -> + returnUs (etaExpand excess_arity us expr ty) + + -- Ensure that the argument of DataToTagOp is evaluated + eval_data2tag_arg :: CoreExpr -> UniqSM (Floats, CoreExpr) + eval_data2tag_arg app@(fun `App` arg) + | exprIsHNF arg -- Includes nullary constructors + = returnUs (emptyFloats, app) -- The arg is evaluated + | otherwise -- Arg not evaluated, so evaluate it + = newVar (exprType arg) `thenUs` \ arg_id -> + let + arg_id1 = setIdUnfolding arg_id evaldUnfolding + in + returnUs (unitFloat (FloatCase arg_id1 arg False ), + fun `App` Var arg_id1) + + eval_data2tag_arg (Note note app) -- Scc notes can appear + = eval_data2tag_arg app `thenUs` \ (floats, app') -> + returnUs (floats, Note note app') + + eval_data2tag_arg other -- Should not happen + = pprPanic "eval_data2tag" (ppr other) + + +-- --------------------------------------------------------------------------- +-- Precipitating the floating bindings +-- --------------------------------------------------------------------------- + +floatRhs :: TopLevelFlag -> RecFlag + -> Id + -> (Floats, CoreExpr) -- Rhs: let binds in body + -> UniqSM (Floats, -- Floats out of this bind + CoreExpr) -- Final Rhs + +floatRhs top_lvl is_rec bndr (floats, rhs) + | isTopLevel top_lvl || exprIsHNF rhs, -- Float to expose value or + allLazy top_lvl is_rec floats -- at top level + = -- Why the test for allLazy? + -- v = f (x `divInt#` y) + -- we don't want to float the case, even if f has arity 2, + -- because floating the case would make it evaluated too early + returnUs (floats, rhs) + + | otherwise + -- Don't float; the RHS isn't a value + = mkBinds floats rhs `thenUs` \ rhs' -> + returnUs (emptyFloats, rhs') + +-- mkLocalNonRec is used only for *nested*, *non-recursive* bindings +mkLocalNonRec :: Id -> RhsDemand -- Lhs: id with demand + -> Floats -> CoreExpr -- Rhs: let binds in body + -> UniqSM (Floats, Id) -- The new Id may have an evaldUnfolding, + -- to record that it's been evaluated + +mkLocalNonRec bndr dem floats rhs + | isUnLiftedType (idType bndr) + -- If this is an unlifted binding, we always make a case for it. + = ASSERT( not (isUnboxedTupleType (idType bndr)) ) + let + float = FloatCase bndr rhs (exprOkForSpeculation rhs) + in + returnUs (addFloat floats float, evald_bndr) + + | isStrict dem + -- It's a strict let so we definitely float all the bindings + = let -- Don't make a case for a value binding, + -- even if it's strict. Otherwise we get + -- case (\x -> e) of ...! + float | exprIsHNF rhs = FloatLet (NonRec bndr rhs) + | otherwise = FloatCase bndr rhs (exprOkForSpeculation rhs) + in + returnUs (addFloat floats float, evald_bndr) + + | otherwise + = floatRhs NotTopLevel NonRecursive bndr (floats, rhs) `thenUs` \ (floats', rhs') -> + returnUs (addFloat floats' (FloatLet (NonRec bndr rhs')), + if exprIsHNF rhs' then evald_bndr else bndr) + + where + evald_bndr = bndr `setIdUnfolding` evaldUnfolding + -- Record if the binder is evaluated + + +mkBinds :: Floats -> CoreExpr -> UniqSM CoreExpr +mkBinds (Floats _ binds) body + | isNilOL binds = returnUs body + | otherwise = deLam body `thenUs` \ body' -> + -- Lambdas are not allowed as the body of a 'let' + returnUs (foldrOL mk_bind body' binds) + where + mk_bind (FloatCase bndr rhs _) body = Case rhs bndr (exprType body) [(DEFAULT, [], body)] + mk_bind (FloatLet bind) body = Let bind body + +etaExpandRhs bndr rhs + = -- Eta expand to match the arity claimed by the binder + -- Remember, after CorePrep we must not change arity + -- + -- Eta expansion might not have happened already, + -- because it is done by the simplifier only when + -- there at least one lambda already. + -- + -- NB1:we could refrain when the RHS is trivial (which can happen + -- for exported things). This would reduce the amount of code + -- generated (a little) and make things a little words for + -- code compiled without -O. The case in point is data constructor + -- wrappers. + -- + -- NB2: we have to be careful that the result of etaExpand doesn't + -- invalidate any of the assumptions that CorePrep is attempting + -- to establish. One possible cause is eta expanding inside of + -- an SCC note - we're now careful in etaExpand to make sure the + -- SCC is pushed inside any new lambdas that are generated. + -- + -- NB3: It's important to do eta expansion, and *then* ANF-ising + -- f = /\a -> g (h 3) -- h has arity 2 + -- If we ANF first we get + -- f = /\a -> let s = h 3 in g s + -- and now eta expansion gives + -- f = /\a -> \ y -> (let s = h 3 in g s) y + -- which is horrible. + -- Eta expanding first gives + -- f = /\a -> \y -> let s = h 3 in g s y + -- + getUniquesUs `thenUs` \ us -> + returnUs (etaExpand arity us rhs (idType bndr)) + where + -- For a GlobalId, take the Arity from the Id. + -- It was set in CoreTidy and must not change + -- For all others, just expand at will + arity | isGlobalId bndr = idArity bndr + | otherwise = exprArity rhs + +-- --------------------------------------------------------------------------- +-- Eliminate Lam as a non-rhs (STG doesn't have such a thing) +-- We arrange that they only show up as the RHS of a let(rec) +-- --------------------------------------------------------------------------- + +deLam :: CoreExpr -> UniqSM CoreExpr +deLam expr = + deLamFloat expr `thenUs` \ (floats, expr) -> + mkBinds floats expr + + +deLamFloat :: CoreExpr -> UniqSM (Floats, CoreExpr) +-- Remove top level lambdas by let-bindinig + +deLamFloat (Note n expr) + = -- You can get things like + -- case e of { p -> coerce t (\s -> ...) } + deLamFloat expr `thenUs` \ (floats, expr') -> + returnUs (floats, Note n expr') + +deLamFloat expr + | null bndrs = returnUs (emptyFloats, expr) + | otherwise + = case tryEta bndrs body of + Just no_lam_result -> returnUs (emptyFloats, no_lam_result) + Nothing -> newVar (exprType expr) `thenUs` \ fn -> + returnUs (unitFloat (FloatLet (NonRec fn expr)), + Var fn) + where + (bndrs,body) = collectBinders expr + +-- Why try eta reduction? Hasn't the simplifier already done eta? +-- But the simplifier only eta reduces if that leaves something +-- trivial (like f, or f Int). But for deLam it would be enough to +-- get to a partial application, like (map f). + +tryEta bndrs expr@(App _ _) + | ok_to_eta_reduce f && + n_remaining >= 0 && + and (zipWith ok bndrs last_args) && + not (any (`elemVarSet` fvs_remaining) bndrs) + = Just remaining_expr + where + (f, args) = collectArgs expr + remaining_expr = mkApps f remaining_args + fvs_remaining = exprFreeVars remaining_expr + (remaining_args, last_args) = splitAt n_remaining args + n_remaining = length args - length bndrs + + ok bndr (Var arg) = bndr == arg + ok bndr other = False + + -- we can't eta reduce something which must be saturated. + ok_to_eta_reduce (Var f) = not (hasNoBinding f) + ok_to_eta_reduce _ = False --safe. ToDo: generalise + +tryEta bndrs (Let bind@(NonRec b r) body) + | not (any (`elemVarSet` fvs) bndrs) + = case tryEta bndrs body of + Just e -> Just (Let bind e) + Nothing -> Nothing + where + fvs = exprFreeVars r + +tryEta bndrs _ = Nothing +\end{code} + + +-- ----------------------------------------------------------------------------- +-- Demands +-- ----------------------------------------------------------------------------- + +\begin{code} +data RhsDemand + = RhsDemand { isStrict :: Bool, -- True => used at least once + isOnceDem :: Bool -- True => used at most once + } + +mkDem :: Demand -> Bool -> RhsDemand +mkDem strict once = RhsDemand (isStrictDmd strict) once + +mkDemTy :: Demand -> Type -> RhsDemand +mkDemTy strict ty = RhsDemand (isStrictDmd strict) + False {- For now -} + +bdrDem :: Id -> RhsDemand +bdrDem id = mkDem (idNewDemandInfo id) + False {- For now -} + +-- safeDem :: RhsDemand +-- safeDem = RhsDemand False False -- always safe to use this + +onceDem :: RhsDemand +onceDem = RhsDemand False True -- used at most once +\end{code} + + + + +%************************************************************************ +%* * +\subsection{Cloning} +%* * +%************************************************************************ + +\begin{code} +-- --------------------------------------------------------------------------- +-- The environment +-- --------------------------------------------------------------------------- + +data CorePrepEnv = CPE (IdEnv Id) -- Clone local Ids + Bool -- True <=> inside a GADT case; see Note [GADT] + +-- Note [GADT] +-- +-- Be careful with cloning inside GADTs. For example, +-- /\a. \f::a. \x::T a. case x of { T -> f True; ... } +-- The case on x may refine the type of f to be a function type. +-- Without this type refinement, exprType (f True) may simply fail, +-- which is bad. +-- +-- Solution: remember when we are inside a potentially-type-refining case, +-- and in that situation use the type from the old occurrence +-- when looking up occurrences + +emptyCorePrepEnv :: CorePrepEnv +emptyCorePrepEnv = CPE emptyVarEnv False + +extendCorePrepEnv :: CorePrepEnv -> Id -> Id -> CorePrepEnv +extendCorePrepEnv (CPE env gadt) id id' = CPE (extendVarEnv env id id') gadt + +lookupCorePrepEnv :: CorePrepEnv -> Id -> Id +-- See Note [GADT] above +lookupCorePrepEnv (CPE env gadt) id + = case lookupVarEnv env id of + Nothing -> id + Just id' | gadt -> setIdType id' (idType id) + | otherwise -> id' + +setGadt :: CorePrepEnv -> AltCon -> CorePrepEnv +setGadt env@(CPE id_env _) (DataAlt data_con) | not (isVanillaDataCon data_con) = CPE id_env True +setGadt env other = env + + +------------------------------------------------------------------------------ +-- Cloning binders +-- --------------------------------------------------------------------------- + +cloneBndrs :: CorePrepEnv -> [Var] -> UniqSM (CorePrepEnv, [Var]) +cloneBndrs env bs = mapAccumLUs cloneBndr env bs + +cloneBndr :: CorePrepEnv -> Var -> UniqSM (CorePrepEnv, Var) +cloneBndr env bndr + | isLocalId bndr + = getUniqueUs `thenUs` \ uniq -> + let + bndr' = setVarUnique bndr uniq + in + returnUs (extendCorePrepEnv env bndr bndr', bndr') + + | otherwise -- Top level things, which we don't want + -- to clone, have become GlobalIds by now + -- And we don't clone tyvars + = returnUs (env, bndr) + + +------------------------------------------------------------------------------ +-- Cloning ccall Ids; each must have a unique name, +-- to give the code generator a handle to hang it on +-- --------------------------------------------------------------------------- + +fiddleCCall :: Id -> UniqSM Id +fiddleCCall id + | isFCallId id = getUniqueUs `thenUs` \ uniq -> + returnUs (id `setVarUnique` uniq) + | otherwise = returnUs id + +------------------------------------------------------------------------------ +-- Generating new binders +-- --------------------------------------------------------------------------- + +newVar :: Type -> UniqSM Id +newVar ty + = seqType ty `seq` + getUniqueUs `thenUs` \ uniq -> + returnUs (mkSysLocal FSLIT("sat") uniq ty) +\end{code} |