#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, setIdUnfolding, setIdType,
- isFCallId, isGlobalId, isImplicitId,
+ isFCallId, isGlobalId,
isLocalId, hasNoBinding, idNewStrictness,
- idUnfolding, isDataConWorkId_maybe, isPrimOpId_maybe
+ isPrimOpId_maybe
)
-import DataCon ( isVanillaDataCon )
+import DataCon ( isVanillaDataCon, dataConWorkId )
import PrimOp ( PrimOp( DataToTagOp ) )
-import HscTypes ( TypeEnv, typeEnvElts, TyThing( AnId ) )
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 -> [CoreBind] -> TypeEnv -> IO [CoreBind]
-corePrepPgm dflags binds types
+corePrepPgm :: DynFlags -> [CoreBind] -> [TyCon] -> IO [CoreBind]
+corePrepPgm dflags binds data_tycons
= do showPass dflags "CorePrep"
us <- mkSplitUniqSupply 's'
- let implicit_binds = mkImplicitBinds types
+ let implicit_binds = mkDataConWorkers data_tycons
-- NB: we must feed mkImplicitBinds through corePrep too
-- so that they are suitably cloned and eta-expanded
-- 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)
- | 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)
+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}
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
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)
-- N-variable fun, better let-bind it
-- ToDo: perhaps we can case-bind rather than let-bind this closure,
-- 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
- | hasNoBinding fn = saturate_it
+ | 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 ->
- let expr' = etaExpand excess_arity us expr ty in
- case isPrimOpId_maybe fn of
- Just DataToTagOp -> hack_data2tag expr'
- other -> returnUs (floats, expr')
+
+ 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
- hack_data2tag app@(Var _fn `App` _ty `App` Var arg_id)
- | isEvaldUnfolding (idUnfolding arg_id) -- Includes nullary constructors
- = returnUs (floats, app) -- The arg is evaluated
- hack_data2tag app@(Var fn `App` Type ty `App` arg)
+ 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 ty `thenUs` \ arg_id1 ->
- let arg_id2 = setIdUnfolding arg_id1 evaldUnfolding
- new_float = FloatCase arg_id2 arg False
+ = newVar (exprType arg) `thenUs` \ arg_id ->
+ let
+ arg_id1 = setIdUnfolding arg_id evaldUnfolding
in
- returnUs (addFloat floats new_float,
- Var fn `App` Type ty `App` Var arg_id2)
+ 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)
-- ---------------------------------------------------------------------------
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)
= 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 (addFloat floats float, evald_bndr)
| otherwise
= floatRhs NotTopLevel NonRecursive bndr (floats, rhs) `thenUs` \ (floats', rhs') ->
returnUs (addFloat floats' (FloatLet (NonRec bndr rhs')),
- if exprIsValue rhs' then evald_bndr else bndr)
+ if exprIsHNF rhs' then evald_bndr else bndr)
where
evald_bndr = bndr `setIdUnfolding` evaldUnfolding
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)]
projects / ghc-hetmet.git / blobdiff