#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}
-- Ensure that the argument of DataToTagOp is evaluated
eval_data2tag_arg :: CoreExpr -> UniqSM (Floats, CoreExpr)
- eval_data2tag_arg app@(fun `App` Var arg_id)
- | isEvaldUnfolding (idUnfolding arg_id) -- Includes nullary constructors
+ 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 (idType arg_id) `thenUs` \ arg_id1 ->
+ = newVar (exprType arg) `thenUs` \ arg_id ->
let
- arg_id2 = setIdUnfolding arg_id1 evaldUnfolding
+ arg_id1 = setIdUnfolding arg_id evaldUnfolding
in
- returnUs (unitFloat (FloatCase arg_id2 (Var arg_id) False ),
- fun `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') ->
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