#include "HsVersions.h"
-import CoreUtils( exprIsTrivial, exprIsAtom, exprType, exprIsValue, etaExpand )
+import CoreUtils( exprType, exprIsValue, etaExpand, exprArity, exprOkForSpeculation )
import CoreFVs ( exprFreeVars )
import CoreLint ( endPass )
import CoreSyn
-import Type ( Type, applyTy, splitFunTy_maybe, isTyVarTy,
- isUnLiftedType, isUnboxedTupleType, repType,
- uaUTy, usOnce, usMany, seqType )
-import Demand ( Demand, isStrict, wwLazy, StrictnessInfo(..) )
-import PrimOp ( PrimOp(..), setCCallUnique )
-import Var ( Var, Id, setVarUnique, globalIdDetails, setGlobalIdDetails )
+import Type ( Type, applyTy, splitFunTy_maybe,
+ isUnLiftedType, isUnboxedTupleType, seqType )
+import TcType ( TyThing( AnId ) )
+import NewDemand ( Demand, isStrictDmd, lazyDmd, StrictSig(..), DmdType(..) )
+import Var ( Var, Id, setVarUnique )
import VarSet
import VarEnv
-import Id ( mkSysLocal, idType, idStrictness, idDemandInfo, idArity,
- setIdType, isPrimOpId_maybe, isLocalId, modifyIdInfo,
- hasNoBinding
+import Id ( mkSysLocal, idType, idNewDemandInfo, idArity,
+ isFCallId, isGlobalId, isImplicitId,
+ isLocalId, hasNoBinding, idNewStrictness,
+ idUnfolding, isDataConWorkId_maybe
)
-import IdInfo ( GlobalIdDetails(..) )
-import HscTypes ( ModDetails(..) )
+import HscTypes ( TypeEnv, typeEnvElts )
+import BasicTypes ( TopLevelFlag(..), isTopLevel, isNotTopLevel,
+ RecFlag(..), isNonRec
+ )
import UniqSupply
import Maybes
import OrdList
import ErrUtils
import CmdLineOpts
+import Util ( listLengthCmp )
import Outputable
\end{code}
4. Ensure that lambdas only occur as the RHS of a binding
(The code generator can't deal with anything else.)
-5. Do the seq/par munging. See notes with mkCase below.
+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.
-6. Clone all local Ids. This means that Tidy Core has the property
- that all Ids are unique, rather than the weaker guarantee of
- no clashes which the simplifier provides.
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 -> ModDetails -> IO ModDetails
-corePrepPgm dflags mod_details
+corePrepPgm :: DynFlags -> [CoreBind] -> TypeEnv -> IO [CoreBind]
+corePrepPgm dflags binds types
= do showPass dflags "CorePrep"
us <- mkSplitUniqSupply 's'
- let new_binds = initUs_ us (corePrepTopBinds emptyVarEnv (md_binds mod_details))
- endPass dflags "CorePrep" Opt_D_dump_sat new_binds
- return (mod_details { md_binds = new_binds })
+
+ let implicit_binds = mkImplicitBinds types
+ -- 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 emptyVarEnv expr)
- dumpIfSet_dyn dflags Opt_D_dump_sat "CorePrep"
+ dumpIfSet_dyn dflags Opt_D_dump_prep "CorePrep"
(ppr new_expr)
return new_expr
+\end{code}
+
+-- -----------------------------------------------------------------------------
+-- Implicit bindings
+-- -----------------------------------------------------------------------------
+
+Create any necessary "implicit" bindings (data constructors etc).
+Namely:
+ * Constructor workers
+ * Constructor wrappers
+ * Data type record selectors
+ * Class op selectors
+
+In the latter three cases, the Id contains the unfolding to use for
+the binding. In the case of 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}
+mkImplicitBinds type_env
+ = [ NonRec id (get_unfolding id)
+ | AnId id <- typeEnvElts type_env, isImplicitId id ]
+ -- The type environment already contains all the implicit Ids,
+ -- so we just filter them out
+ --
+ -- The etaExpand is so that the manifest arity of the
+ -- binding matches its claimed arity, which is an
+ -- invariant of top level bindings going into the code gen
+
+get_unfolding id -- See notes above
+ | Just data_con <- isDataConWorkId_maybe id = Var id -- The ice is thin here, but it works
+ -- CorePrep will eta-expand it
+ | otherwise = unfoldingTemplate (idUnfolding id)
+\end{code}
+
+\begin{code}
-- ---------------------------------------------------------------------------
-- Dealing with bindings
-- ---------------------------------------------------------------------------
data FloatingBind = FloatLet CoreBind
- | FloatCase Id CoreExpr
+ | FloatCase Id CoreExpr Bool
+ -- The bool indicates "ok-for-speculation"
-type CloneEnv = IdEnv Id -- Clone local Ids
+data Floats = Floats OkToSpec (OrdList FloatingBind)
-allLazy :: OrdList FloatingBind -> Bool
-allLazy floats = foldOL check True floats
- where
- check (FloatLet _) y = y
- check (FloatCase _ _) y = False
+-- 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
-corePrepTopBinds :: CloneEnv -> [CoreBind] -> UniqSM [CoreBind]
-corePrepTopBinds env [] = returnUs []
+emptyFloats :: Floats
+emptyFloats = Floats OkToSpec nilOL
-corePrepTopBinds env (bind : binds)
- = corePrepBind env bind `thenUs` \ (env', floats) ->
- ASSERT( allLazy floats )
- corePrepTopBinds env' binds `thenUs` \ binds' ->
- returnUs (foldOL add binds' floats)
+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
- add (FloatLet bind) binds = bind : binds
+ 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
+type CloneEnv = IdEnv Id -- Clone local Ids
+
+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
-- ---------------------------------------------------------------------------
-corePrepBind :: CloneEnv -> CoreBind -> UniqSM (CloneEnv, OrdList FloatingBind)
--- Used for non-top-level bindings
+corePrepTopBinds :: [CoreBind] -> UniqSM Floats
+corePrepTopBinds binds
+ = go emptyVarEnv 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 :: CloneEnv -> CoreBind -> UniqSM (CloneEnv, 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 :: CloneEnv -> CoreBind -> UniqSM (CloneEnv, Floats)
+ -- This one is used for *local* bindings
corePrepBind env (NonRec bndr rhs)
- = corePrepExprFloat env rhs `thenUs` \ (floats, rhs') ->
- cloneBndr env bndr `thenUs` \ (env', bndr') ->
- mkNonRec bndr' (bdrDem bndr') floats rhs' `thenUs` \ floats' ->
+ = etaExpandRhs bndr rhs `thenUs` \ rhs1 ->
+ corePrepExprFloat env rhs1 `thenUs` \ (floats, rhs2) ->
+ cloneBndr env bndr `thenUs` \ (env', bndr') ->
+ mkLocalNonRec bndr' (bdrDem bndr') floats rhs2 `thenUs` \ floats' ->
returnUs (env', floats')
-corePrepBind env (Rec pairs)
- -- Don't bother to try to float bindings out of RHSs
- -- (compare mkNonRec, which does try)
- = cloneBndrs env bndrs `thenUs` \ (env', bndrs') ->
- mapUs (corePrepAnExpr env') rhss `thenUs` \ rhss' ->
- returnUs (env', unitOL (FloatLet (Rec (bndrs' `zip` rhss'))))
+corePrepBind env (Rec pairs) = corePrepRecPairs NotTopLevel env pairs
+
+--------------------------------
+corePrepRecPairs :: TopLevelFlag -> CloneEnv
+ -> [(Id,CoreExpr)] -- Recursive bindings
+ -> UniqSM (CloneEnv, 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
- (bndrs, rhss) = unzip pairs
+ -- 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
+
+--------------------------------
+corePrepRhs :: TopLevelFlag -> RecFlag
+ -> CloneEnv -> (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
-- ---------------------------------------------------------------------------
-- This is where we arrange that a non-trivial argument is let-bound
corePrepArg :: CloneEnv -> CoreArg -> RhsDemand
- -> UniqSM (OrdList FloatingBind, CoreArg)
+ -> UniqSM (Floats, CoreArg)
corePrepArg env arg dem
= corePrepExprFloat env arg `thenUs` \ (floats, arg') ->
- if needs_binding arg'
- then returnUs (floats, arg')
- else newVar (exprType arg') `thenUs` \ v ->
- mkNonRec v dem floats arg' `thenUs` \ floats' ->
- returnUs (floats', Var v)
-
-needs_binding | opt_KeepStgTypes = exprIsAtom
- | otherwise = exprIsTrivial
+ if exprIsTrivial arg'
+ then returnUs (floats, arg')
+ else newVar (exprType arg') `thenUs` \ v ->
+ mkLocalNonRec v dem floats arg' `thenUs` \ floats' ->
+ 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
mkBinds floats expr
-corePrepExprFloat :: CloneEnv -> CoreExpr -> UniqSM (OrdList FloatingBind, CoreExpr)
+corePrepExprFloat :: CloneEnv -> CoreExpr -> UniqSM (Floats, CoreExpr)
-- If
-- e ===> (bs, e')
-- then
= fiddleCCall v `thenUs` \ v1 ->
let v2 = lookupVarEnv env v1 `orElse` v1 in
maybeSaturate v2 (Var v2) 0 (idType v2) `thenUs` \ app ->
- returnUs (nilOL, app)
+ returnUs (emptyFloats, app)
corePrepExprFloat env expr@(Type _)
- = returnUs (nilOL, expr)
+ = returnUs (emptyFloats, expr)
corePrepExprFloat env expr@(Lit lit)
- = returnUs (nilOL, expr)
+ = 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 `appOL` floats, new_body)
+ returnUs (new_binds `appendFloats` floats, new_body)
corePrepExprFloat env (Note n@(SCC _) expr)
= corePrepAnExpr env expr `thenUs` \ expr1 ->
- deLam expr1 `thenUs` \ expr2 ->
- returnUs (nilOL, Note n expr2)
+ 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 _ _)
- = corePrepAnExpr env body `thenUs` \ body' ->
- returnUs (nilOL, mkLams bndrs body')
+ = 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 alts)
- = corePrepExprFloat env scrut `thenUs` \ (floats, scrut') ->
+ = corePrepExprFloat env scrut `thenUs` \ (floats1, scrut1) ->
+ deLamFloat scrut1 `thenUs` \ (floats2, scrut2) ->
cloneBndr env bndr `thenUs` \ (env', bndr') ->
mapUs (sat_alt env') alts `thenUs` \ alts' ->
- returnUs (floats, mkCase scrut' bndr' alts')
+ returnUs (floats1 `appendFloats` floats2 , Case scrut2 bndr' alts')
where
sat_alt env (con, bs, rhs)
= cloneBndrs env bs `thenUs` \ (env', bs') ->
(CoreExpr,Int), -- the head of the application,
-- and no. of args it was applied to
Type, -- type of the whole expr
- OrdList FloatingBind, -- any floats we pulled out
+ Floats, -- any floats we pulled out
[Demand]) -- remaining argument demands
collect_args (App fun arg@(Type arg_ty)) 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)
- [] -> (wwLazy, [])
+ (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 `appOL` floats, ss_rest)
+ returnUs (App fun' arg', hd, res_ty, fs `appendFloats` floats, ss_rest)
collect_args (Var v) depth
= fiddleCCall v `thenUs` \ v1 ->
let v2 = lookupVarEnv env v1 `orElse` v1 in
- returnUs (Var v2, (Var v2, depth), idType v2, nilOL, stricts)
+ returnUs (Var v2, (Var v2, depth), idType v2, emptyFloats, stricts)
where
- stricts = case idStrictness v of
- StrictnessInfo demands _
- | depth >= length demands -> demands
- | otherwise -> []
- other -> []
+ 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")
returnUs (Note note fun', hd, fun_ty, floats, ss)
-- non-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 ->
- mkNonRec fn_id onceDem fun_floats fun `thenUs` \ floats ->
+ = corePrepExprFloat env fun `thenUs` \ (fun_floats, fun') ->
+ newVar ty `thenUs` \ fn_id ->
+ mkLocalNonRec fn_id onceDem fun_floats fun' `thenUs` \ floats ->
returnUs (Var fn_id, (Var fn_id, depth), ty, floats, [])
where
ty = exprType fun
- ignore_note InlineCall = True
- ignore_note InlineMe = True
- ignore_note _other = False
- -- we don't ignore SCCs, since they require some code generation
+ 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 :: Id -> CoreExpr -> Int -> Type -> UniqSM CoreExpr
maybeSaturate fn expr n_args ty
| hasNoBinding fn = saturate_it
- | otherwise = returnUs expr
+ | otherwise = returnUs expr
where
fn_arity = idArity fn
excess_arity = fn_arity - n_args
- saturate_it = getUs `thenUs` \ us ->
+ saturate_it = getUniquesUs `thenUs` \ us ->
returnUs (etaExpand excess_arity us expr ty)
-- ---------------------------------------------------------------------------
-- Precipitating the floating bindings
-- ---------------------------------------------------------------------------
--- mkNonRec is used for both top level and local bindings
-mkNonRec :: Id -> RhsDemand -- Lhs: id with demand
- -> OrdList FloatingBind -> CoreExpr -- Rhs: let binds in body
- -> UniqSM (OrdList FloatingBind)
-mkNonRec bndr dem floats rhs
- | exprIsValue rhs && allLazy floats -- Notably constructor applications
- = -- Why the test for allLazy? You might think that the only
- -- floats we can get out of a value are eta expansions
- -- e.g. C $wJust ==> let s = \x -> $wJust x in C s
- -- Here we want to float the s binding.
- --
- -- But if the programmer writes this:
- -- f x = case x of { (a,b) -> \y -> a }
- -- then the strictness analyser may say that f has strictness "S"
- -- Later the eta expander will transform to
- -- f x y = case x of { (a,b) -> a }
- -- So now f has arity 2. Now CorePrep may see
- -- v = f E
- -- so the E argument will turn into a FloatCase.
- -- Indeed we should end up with
- -- v = case E of { r -> f r }
- -- That is, we should not float, even though (f r) is a value
- --
- -- Similarly, given
+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 || exprIsValue 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 `snocOL` FloatLet (NonRec bndr rhs))
+ --
+ -- Finally, eta-expand the RHS, for the benefit of the code gen
+ returnUs (floats, rhs)
- | isUnLiftedType bndr_rep_ty || isStrictDem dem
- -- It's a strict let, or the binder is unlifted,
- -- so we definitely float all the bindings
- = ASSERT( not (isUnboxedTupleType bndr_rep_ty) )
- returnUs (floats `snocOL` FloatCase bndr 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
+
+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)
+
+ | 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 | exprIsValue rhs = FloatLet (NonRec bndr rhs)
+ | otherwise = FloatCase bndr rhs (exprOkForSpeculation rhs)
+ in
+ returnUs (addFloat floats float)
| otherwise
- -- Don't float
- = mkBinds floats rhs `thenUs` \ rhs' ->
- returnUs (unitOL (FloatLet (NonRec bndr rhs')))
+ = floatRhs NotTopLevel NonRecursive bndr (floats, rhs) `thenUs` \ (floats', rhs') ->
+ returnUs (addFloat floats' (FloatLet (NonRec bndr rhs')))
where
- bndr_rep_ty = repType (idType bndr)
+ bndr_ty = idType bndr
+
-mkBinds :: OrdList FloatingBind -> CoreExpr -> UniqSM CoreExpr
-mkBinds binds body
+mkBinds :: Floats -> CoreExpr -> UniqSM CoreExpr
+mkBinds (Floats _ binds) body
| isNilOL binds = returnUs body
| otherwise = deLam body `thenUs` \ body' ->
- returnUs (foldOL mk_bind body' binds)
+ returnUs (foldrOL mk_bind body' binds)
+ where
+ mk_bind (FloatCase bndr rhs _) body = Case rhs bndr [(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
- mk_bind (FloatCase bndr rhs) body = mkCase rhs bndr [(DEFAULT, [], body)]
- mk_bind (FloatLet bind) body = Let bind body
+ -- 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 :: 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
-deLam (Note n expr)
+deLamFloat (Note n expr)
= -- You can get things like
-- case e of { p -> coerce t (\s -> ...) }
- deLam expr `thenUs` \ expr' ->
- returnUs (Note n expr')
-
-deLam expr
- | null bndrs = returnUs expr
- | otherwise = case tryEta bndrs body of
- Just no_lam_result -> returnUs no_lam_result
- Nothing -> newVar (exprType expr) `thenUs` \ fn ->
- returnUs (Let (NonRec fn expr) (Var fn))
+ 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
n_remaining = length args - length bndrs
ok bndr (Var arg) = bndr == arg
- ok bndr other = False
+ ok bndr other = False
-- we can't eta reduce something which must be saturated.
ok_to_eta_reduce (Var f) = not (hasNoBinding f)
-- -----------------------------------------------------------------------------
--- Do the seq and par transformation
--- -----------------------------------------------------------------------------
-
-Here we do two pre-codegen transformations:
-
-1. case seq# a of {
- 0 -> seqError ...
- DEFAULT -> rhs }
- ==>
- case a of { DEFAULT -> rhs }
-
-
-2. case par# a of {
- 0 -> parError ...
- DEFAULT -> rhs }
- ==>
- case par# a of {
- DEFAULT -> rhs }
-
-NB: seq# :: a -> Int# -- Evaluate value and return anything
- par# :: a -> Int# -- Spark value and return anything
-
-These transformations can't be done earlier, or else we might
-think that the expression was strict in the variables in which
-rhs is strict --- but that would defeat the purpose of seq and par.
-
-
-\begin{code}
-mkCase scrut@(Var fn `App` Type ty `App` arg) bndr alts
- = case isPrimOpId_maybe fn of
- Just ParOp -> Case scrut bndr [deflt_alt]
- Just SeqOp -> Case arg new_bndr [deflt_alt]
- other -> Case scrut bndr alts
- where
- (deflt_alt@(_,_,rhs) : _) = [alt | alt@(DEFAULT,_,_) <- alts]
-
- -- The binder shouldn't be used in the expression!
- new_bndr = ASSERT2( not (bndr `elemVarSet` exprFreeVars rhs), ppr bndr )
- setIdType bndr (exprType arg)
- -- NB: SeqOp :: forall a. a -> Int#
- -- So bndr has type Int#
- -- But now we are going to scrutinise the SeqOp's argument directly,
- -- so we must change the type of the case binder to match that
- -- of the argument expression e.
-
-mkCase scrut bndr alts = Case scrut bndr alts
-\end{code}
-
-
--- -----------------------------------------------------------------------------
-- Demands
-- -----------------------------------------------------------------------------
\begin{code}
data RhsDemand
- = RhsDemand { isStrictDem :: Bool, -- True => used at least once
+ = RhsDemand { isStrict :: Bool, -- True => used at least once
isOnceDem :: Bool -- True => used at most once
}
mkDem :: Demand -> Bool -> RhsDemand
-mkDem strict once = RhsDemand (isStrict strict) once
+mkDem strict once = RhsDemand (isStrictDmd strict) once
mkDemTy :: Demand -> Type -> RhsDemand
-mkDemTy strict ty = RhsDemand (isStrict strict) (isOnceTy ty)
-
-isOnceTy :: Type -> Bool
-isOnceTy ty
- =
-#ifdef USMANY
- opt_UsageSPOn && -- can't expect annotations if -fusagesp is off
-#endif
- once
- where
- u = uaUTy ty
- once | u == usOnce = True
- | u == usMany = False
- | isTyVarTy u = False -- if unknown at compile-time, is Top ie usMany
+mkDemTy strict ty = RhsDemand (isStrictDmd strict)
+ False {- For now -}
bdrDem :: Id -> RhsDemand
-bdrDem id = mkDem (idDemandInfo id) (isOnceTy (idType id))
+bdrDem id = mkDem (idNewDemandInfo id)
+ False {- For now -}
-safeDem, onceDem :: RhsDemand
-safeDem = RhsDemand False False -- always safe to use this
+-- safeDem :: RhsDemand
+-- safeDem = RhsDemand False False -- always safe to use this
+
+onceDem :: RhsDemand
onceDem = RhsDemand False True -- used at most once
\end{code}
cloneBndr :: CloneEnv -> Var -> UniqSM (CloneEnv, Var)
cloneBndr env bndr
- | isId bndr && isLocalId bndr -- Top level things, which we don't want
- -- to clone, have become ConstantIds by now
+ | isLocalId bndr
= getUniqueUs `thenUs` \ uniq ->
let
bndr' = setVarUnique bndr uniq
in
returnUs (extendVarEnv env bndr bndr', bndr')
- | otherwise = returnUs (env, 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,
fiddleCCall :: Id -> UniqSM Id
fiddleCCall id
- = case globalIdDetails id of
- PrimOpId (CCallOp ccall) ->
- -- Make a guaranteed unique name for a dynamic ccall.
- getUniqueUs `thenUs` \ uniq ->
- returnUs (setGlobalIdDetails id
- (PrimOpId (CCallOp (setCCallUnique ccall uniq))))
- other -> returnUs id
+ | isFCallId id = getUniqueUs `thenUs` \ uniq ->
+ returnUs (id `setVarUnique` uniq)
+ | otherwise = returnUs id
------------------------------------------------------------------------------
-- Generating new binders
newVar :: Type -> UniqSM Id
newVar ty
- = getUniqueUs `thenUs` \ uniq ->
- seqType ty `seq`
- returnUs (mkSysLocal SLIT("sat") uniq ty)
+ = seqType ty `seq`
+ getUniqueUs `thenUs` \ uniq ->
+ returnUs (mkSysLocal FSLIT("sat") uniq ty)
\end{code}
projects / ghc-hetmet.git / blobdiff