#include "HsVersions.h"
-import CoreUtils( exprType, exprIsValue, etaExpand, exprArity, exprOkForSpeculation )
+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,
+import Id ( mkSysLocal, idType, idNewDemandInfo, idArity, setIdUnfolding, setIdType,
isFCallId, isGlobalId,
isLocalId, hasNoBinding, idNewStrictness,
- isDataConId_maybe, idUnfolding
+ isPrimOpId_maybe
)
-import HscTypes ( ModGuts(..), ModGuts, implicitTyThingIds, typeEnvElts )
+import DataCon ( isVanillaDataCon, dataConWorkId )
+import PrimOp ( PrimOp( DataToTagOp ) )
import BasicTypes ( TopLevelFlag(..), isTopLevel, isNotTopLevel,
RecFlag(..), isNonRec
)
import Maybes
import OrdList
import ErrUtils
-import CmdLineOpts
+import DynFlags
import Util ( listLengthCmp )
import Outputable
\end{code}
-- -----------------------------------------------------------------------------
\begin{code}
-corePrepPgm :: DynFlags -> ModGuts -> IO ModGuts
-corePrepPgm dflags mod_impl
+corePrepPgm :: DynFlags -> [CoreBind] -> [TyCon] -> IO [CoreBind]
+corePrepPgm dflags binds data_tycons
= do showPass dflags "CorePrep"
us <- mkSplitUniqSupply 's'
- let implicit_binds = mkImplicitBinds (mg_types mod_impl)
+ 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 (mg_binds mod_impl) `thenUs` \ floats1 ->
+ corePrepTopBinds binds `thenUs` \ floats1 ->
corePrepTopBinds implicit_binds `thenUs` \ floats2 ->
- returnUs (deFloatTop (floats1 `appOL` floats2))
+ returnUs (deFloatTop (floats1 `appendFloats` floats2))
)
endPass dflags "CorePrep" Opt_D_dump_prep binds_out
- return (mod_impl { mg_binds = 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)
+ let new_expr = initUs_ us (corePrepAnExpr emptyCorePrepEnv expr)
dumpIfSet_dyn dflags Opt_D_dump_prep "CorePrep"
(ppr new_expr)
return new_expr
-- 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
+Create any necessary "implicit" bindings for data con workers. We
+create the rather strange (non-recursive!) binding
$wC = \x y -> $wC x y
partial applications. But it's easier to let them through.
\begin{code}
-mkImplicitBinds type_env
- = [ NonRec id (get_unfolding id)
- | id <- implicitTyThingIds (typeEnvElts type_env) ]
- -- 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 <- isDataConId_maybe id = Var id -- The ice is thin here, but it works
- | otherwise = unfoldingTemplate (idUnfolding id)
+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}
| 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
-type CloneEnv = IdEnv Id -- Clone local Ids
-
-deFloatTop :: OrdList FloatingBind -> [CoreBind]
+deFloatTop :: Floats -> [CoreBind]
-- For top level only; we don't expect any FloatCases
-deFloatTop floats
+deFloatTop (Floats _ floats)
= foldrOL get [] floats
where
get (FloatLet b) bs = b:bs
get b bs = pprPanic "corePrepPgm" (ppr b)
-allLazy :: TopLevelFlag -> RecFlag -> OrdList FloatingBind -> Bool
-allLazy top_lvl is_rec floats
- = foldrOL check True floats
- where
- unboxed_ok = isNotTopLevel top_lvl && isNonRec is_rec
-
- check (FloatLet _) y = y
- check (FloatCase _ _ ok_for_spec) y = unboxed_ok && ok_for_spec && y
- -- 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
+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 (OrdList FloatingBind)
+corePrepTopBinds :: [CoreBind] -> UniqSM Floats
corePrepTopBinds binds
- = go emptyVarEnv binds
+ = go emptyCorePrepEnv binds
where
- go env [] = returnUs nilOL
+ go env [] = returnUs emptyFloats
go env (bind : binds) = corePrepTopBind env bind `thenUs` \ (env', bind') ->
go env' binds `thenUs` \ binds' ->
- returnUs (bind' `appOL` binds')
+ returnUs (bind' `appendFloats` binds')
-- NB: we do need to float out of top-level bindings
-- Consider x = length [True,False]
-- 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, OrdList FloatingBind)
+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', floats `snocOL` FloatLet (NonRec bndr' rhs'))
+ returnUs (env', addFloat floats (FloatLet (NonRec bndr' rhs')))
corePrepTopBind env (Rec pairs) = corePrepRecPairs TopLevel env pairs
--------------------------------
-corePrepBind :: CloneEnv -> CoreBind -> UniqSM (CloneEnv, OrdList FloatingBind)
+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` \ (env', bndr') ->
- mkLocalNonRec bndr' (bdrDem bndr') floats rhs2 `thenUs` \ floats' ->
- returnUs (env', floats')
+ 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 -> CloneEnv
+corePrepRecPairs :: TopLevelFlag -> CorePrepEnv
-> [(Id,CoreExpr)] -- Recursive bindings
- -> UniqSM (CloneEnv, OrdList FloatingBind)
+ -> 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', unitOL (FloatLet (Rec (flatten (concatOL floats_s) bndrs' 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 bndrs rhss = foldrOL get (bndrs `zip` rhss) floats
+ 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
- -> CloneEnv -> (Id, CoreExpr)
- -> UniqSM (OrdList FloatingBind, CoreExpr)
+ -> 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' ->
-- ---------------------------------------------------------------------------
-- This is where we arrange that a non-trivial argument is let-bound
-corePrepArg :: CloneEnv -> CoreArg -> RhsDemand
- -> UniqSM (OrdList FloatingBind, CoreArg)
+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' ->
- returnUs (floats', Var 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
-- Dealing with expressions
-- ---------------------------------------------------------------------------
-corePrepAnExpr :: CloneEnv -> CoreExpr -> UniqSM CoreExpr
+corePrepAnExpr :: CorePrepEnv -> CoreExpr -> UniqSM CoreExpr
corePrepAnExpr env expr
= corePrepExprFloat env expr `thenUs` \ (floats, expr) ->
mkBinds floats expr
-corePrepExprFloat :: CloneEnv -> CoreExpr -> UniqSM (OrdList FloatingBind, CoreExpr)
+corePrepExprFloat :: CorePrepEnv -> CoreExpr -> UniqSM (Floats, CoreExpr)
-- If
-- e ===> (bs, e')
-- then
corePrepExprFloat env (Var v)
= fiddleCCall v `thenUs` \ v1 ->
- let v2 = lookupVarEnv env v1 `orElse` v1 in
- maybeSaturate v2 (Var v2) 0 (idType v2) `thenUs` \ app ->
- returnUs (nilOL, app)
+ let
+ v2 = lookupCorePrepEnv env v1
+ in
+ maybeSaturate v2 (Var v2) 0 emptyFloats (idType v2)
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 ->
corePrepExprFloat env expr@(Lam _ _)
= cloneBndrs env bndrs `thenUs` \ (env', bndrs') ->
corePrepAnExpr env' body `thenUs` \ body' ->
- returnUs (nilOL, mkLams bndrs' body')
+ returnUs (emptyFloats, mkLams bndrs' body')
where
(bndrs,body) = collectBinders expr
-corePrepExprFloat env (Case scrut bndr alts)
+corePrepExprFloat env (Case scrut bndr ty alts)
= corePrepExprFloat env scrut `thenUs` \ (floats1, scrut1) ->
deLamFloat scrut1 `thenUs` \ (floats2, scrut2) ->
- cloneBndr env bndr `thenUs` \ (env', bndr') ->
+ 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 `appOL` floats2 , Case scrut2 bndr' alts')
+ returnUs (floats1 `appendFloats` floats2 , Case scrut2 bndr2 ty alts')
where
sat_alt env (con, bs, rhs)
- = cloneBndrs env bs `thenUs` \ (env', bs') ->
- corePrepAnExpr env' rhs `thenUs` \ rhs1 ->
+ = 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)
-- Now deal with the function
case head of
- Var fn_id -> maybeSaturate fn_id app depth ty `thenUs` \ app' ->
- returnUs (floats, app')
-
+ Var fn_id -> maybeSaturate fn_id app depth floats ty
_other -> returnUs (floats, app)
where
(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
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)
+ 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 _)
returnUs (Note (Coerce ty1 ty2) fun', hd, ty1, floats, ss)
collect_args (Note note fun) depth
- | ignore_note note
+ | 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 (Note note fun', hd, fun_ty, floats, ss)
+ returnUs (fun', hd, fun_ty, floats, ss)
- -- non-variable fun, better let-bind it
+ -- 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 ->
- returnUs (Var fn_id, (Var fn_id, depth), ty, floats, [])
+ 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 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 deals with saturating primops and constructors
-- The type is the type of the entire application
-maybeSaturate :: Id -> CoreExpr -> Int -> Type -> UniqSM CoreExpr
-maybeSaturate fn expr n_args ty
- | hasNoBinding fn = saturate_it
- | otherwise = returnUs expr
+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 = getUniquesUs `thenUs` \ us ->
- returnUs (etaExpand excess_arity us expr ty)
+
+ 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
- -> (OrdList FloatingBind, CoreExpr) -- Rhs: let binds in body
- -> UniqSM (OrdList FloatingBind, -- Floats out of this bind
- CoreExpr) -- Final Rhs
+ -> (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
+ | 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
- --
- -- Finally, eta-expand the RHS, for the benefit of the code gen
returnUs (floats, rhs)
| otherwise
-- Don't float; the RHS isn't a value
= mkBinds floats rhs `thenUs` \ rhs' ->
- returnUs (nilOL, rhs')
+ returnUs (emptyFloats, rhs')
-- mkLocalNonRec is used only for *nested*, *non-recursive* bindings
-mkLocalNonRec :: Id -> RhsDemand -- Lhs: id with demand
- -> OrdList FloatingBind -> CoreExpr -- Rhs: let binds in body
- -> UniqSM (OrdList FloatingBind)
+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)
let
float = FloatCase bndr rhs (exprOkForSpeculation rhs)
in
- returnUs (floats `snocOL` float)
+ 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 | exprIsValue rhs = FloatLet (NonRec bndr rhs)
+ float | exprIsHNF rhs = FloatLet (NonRec bndr rhs)
| otherwise = FloatCase bndr rhs (exprOkForSpeculation rhs)
in
- returnUs (floats `snocOL` float)
+ returnUs (addFloat floats float, evald_bndr)
| otherwise
= floatRhs NotTopLevel NonRecursive bndr (floats, rhs) `thenUs` \ (floats', rhs') ->
- returnUs (floats' `snocOL` FloatLet (NonRec bndr rhs'))
+ returnUs (addFloat floats' (FloatLet (NonRec bndr rhs')),
+ if exprIsHNF rhs' then evald_bndr else bndr)
where
- bndr_ty = idType bndr
+ evald_bndr = bndr `setIdUnfolding` evaldUnfolding
+ -- Record if the binder is evaluated
-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' ->
+ -- 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 [(DEFAULT, [], body)]
+ mk_bind (FloatCase bndr rhs _) body = Case rhs bndr (exprType body) [(DEFAULT, [], body)]
mk_bind (FloatLet bind) body = Let bind body
etaExpandRhs bndr rhs
mkBinds floats expr
-deLamFloat :: CoreExpr -> UniqSM (OrdList FloatingBind, CoreExpr)
+deLamFloat :: CoreExpr -> UniqSM (Floats, CoreExpr)
-- Remove top level lambdas by let-bindinig
deLamFloat (Note n expr)
returnUs (floats, Note n expr')
deLamFloat expr
- | null bndrs = returnUs (nilOL, expr)
+ | null bndrs = returnUs (emptyFloats, expr)
| otherwise
= case tryEta bndrs body of
- Just no_lam_result -> returnUs (nilOL, no_lam_result)
+ Just no_lam_result -> returnUs (emptyFloats, no_lam_result)
Nothing -> newVar (exprType expr) `thenUs` \ fn ->
- returnUs (unitOL (FloatLet (NonRec fn expr)),
+ 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)
%************************************************************************
\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 :: CloneEnv -> [Var] -> UniqSM (CloneEnv, [Var])
+cloneBndrs :: CorePrepEnv -> [Var] -> UniqSM (CorePrepEnv, [Var])
cloneBndrs env bs = mapAccumLUs cloneBndr env bs
-cloneBndr :: CloneEnv -> Var -> UniqSM (CloneEnv, Var)
+cloneBndr :: CorePrepEnv -> Var -> UniqSM (CorePrepEnv, Var)
cloneBndr env bndr
| isLocalId bndr
= getUniqueUs `thenUs` \ uniq ->
let
bndr' = setVarUnique bndr uniq
in
- returnUs (extendVarEnv env bndr bndr', bndr')
+ returnUs (extendCorePrepEnv env bndr bndr', bndr')
| otherwise -- Top level things, which we don't want
-- to clone, have become GlobalIds by now
projects / ghc-hetmet.git / blobdiff