import VarEnv
import Id ( mkSysLocal, idType, idNewDemandInfo, idArity,
setIdType, isPrimOpId_maybe, isFCallId, isGlobalId,
- hasNoBinding, idNewStrictness, setIdArity
+ isLocalId, hasNoBinding, idNewStrictness,
+ isDataConId_maybe, idUnfolding
)
-import HscTypes ( ModDetails(..) )
+import HscTypes ( ModDetails(..), implicitTyThingIds, typeEnvElts )
+import Unique ( mkBuiltinUnique )
import BasicTypes ( Arity, TopLevelFlag(..), isTopLevel, isNotTopLevel,
RecFlag(..), isNonRec
)
import OrdList
import ErrUtils
import CmdLineOpts
+import Util ( listLengthCmp )
import Outputable
\end{code}
5. Do the seq/par munging. See notes with mkCase below.
-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.
+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
-- -----------------------------------------------------------------------------
= do showPass dflags "CorePrep"
us <- mkSplitUniqSupply 's'
- let floats = initUs_ us (corePrepTopBinds emptyVarEnv (md_binds mod_details))
- new_binds = foldrOL get [] floats
- get (FloatLet b) bs = b:bs
- get b bs = pprPanic "corePrepPgm" (ppr b)
+ let implicit_binds = mkImplicitBinds (md_types mod_details)
+ -- NB: we must feed mkImplicitBinds through corePrep too
+ -- so that they are suitably cloned and eta-expanded
- endPass dflags "CorePrep" Opt_D_dump_prep new_binds
- return (mod_details { md_binds = new_binds })
+ binds_out = initUs_ us (
+ corePrepTopBinds (md_binds mod_details) `thenUs` \ floats1 ->
+ corePrepTopBinds implicit_binds `thenUs` \ floats2 ->
+ returnUs (deFloatTop (floats1 `appOL` floats2))
+ )
+
+ endPass dflags "CorePrep" Opt_D_dump_prep binds_out
+ return (mod_details { md_binds = binds_out })
corePrepExpr :: DynFlags -> CoreExpr -> IO CoreExpr
corePrepExpr dflags expr
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)
+ | 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
+ where
+ tmpl_uniqs = map mkBuiltinUnique [1..]
+
+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)
+\end{code}
+
+\begin{code}
-- ---------------------------------------------------------------------------
-- Dealing with bindings
-- ---------------------------------------------------------------------------
type CloneEnv = IdEnv Id -- Clone local Ids
+deFloatTop :: OrdList FloatingBind -> [CoreBind]
+-- For top level only; we don't expect any FloatCases
+deFloatTop 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
-- Bindings
-- ---------------------------------------------------------------------------
-corePrepTopBinds :: CloneEnv -> [CoreBind] -> UniqSM (OrdList FloatingBind)
-corePrepTopBinds env [] = returnUs nilOL
-
-corePrepTopBinds env (bind : binds)
- = corePrepTopBind env bind `thenUs` \ (env', bind') ->
- corePrepTopBinds env' binds `thenUs` \ binds' ->
- returnUs (bind' `appOL` binds')
+corePrepTopBinds :: [CoreBind] -> UniqSM (OrdList FloatingBind)
+corePrepTopBinds binds
+ = go emptyVarEnv binds
+ where
+ go env [] = returnUs nilOL
+ go env (bind : binds) = corePrepTopBind env bind `thenUs` \ (env', bind') ->
+ go env' binds `thenUs` \ binds' ->
+ returnUs (bind' `appOL` binds')
-- NB: we do need to float out of top-level bindings
-- Consider x = length [True,False]
-- x* = f a
-- And then x will actually end up case-bound
+--------------------------------
corePrepTopBind :: CloneEnv -> CoreBind -> UniqSM (CloneEnv, OrdList FloatingBind)
corePrepTopBind env (NonRec bndr rhs)
= cloneBndr env bndr `thenUs` \ (env', bndr') ->
corePrepTopBind env (Rec pairs) = corePrepRecPairs TopLevel env pairs
+--------------------------------
corePrepBind :: CloneEnv -> CoreBind -> UniqSM (CloneEnv, OrdList FloatingBind)
-- This one is used for *local* bindings
corePrepBind env (NonRec bndr rhs)
- = corePrepExprFloat env rhs `thenUs` \ (floats, rhs') ->
+ = etaExpandRhs bndr rhs `thenUs` \ rhs1 ->
+ corePrepExprFloat env rhs1 `thenUs` \ (floats, rhs2) ->
cloneBndr env bndr `thenUs` \ (env', bndr') ->
- mkLocalNonRec bndr' (bdrDem bndr') floats rhs' `thenUs` \ floats' ->
+ mkLocalNonRec bndr' (bdrDem bndr') floats rhs2 `thenUs` \ floats' ->
returnUs (env', floats')
corePrepBind env (Rec pairs) = corePrepRecPairs NotTopLevel env pairs
-> UniqSM (OrdList FloatingBind, CoreExpr)
-- Used for top-level bindings, and local recursive bindings
corePrepRhs top_lvl is_rec env (bndr, rhs)
- = corePrepExprFloat env rhs `thenUs` \ floats_w_rhs ->
+ = etaExpandRhs bndr rhs `thenUs` \ rhs' ->
+ corePrepExprFloat env rhs' `thenUs` \ floats_w_rhs ->
floatRhs top_lvl is_rec bndr floats_w_rhs
-> UniqSM (OrdList FloatingBind, CoreArg)
corePrepArg env arg dem
= corePrepExprFloat env arg `thenUs` \ (floats, arg') ->
- if no_binding_needed arg'
+ if exprIsTrivial arg'
then returnUs (floats, arg')
- else newVar (exprType arg') (exprArity arg') `thenUs` \ v ->
- mkLocalNonRec v dem floats arg' `thenUs` \ floats' ->
+ else newVar (exprType arg') `thenUs` \ v ->
+ mkLocalNonRec v dem floats arg' `thenUs` \ floats' ->
returnUs (floats', Var v)
-no_binding_needed | opt_RuntimeTypes = exprIsAtom
- | otherwise = exprIsTrivial
-
-- version that doesn't consider an scc annotation to be trivial.
-exprIsTrivial (Var v)
- | hasNoBinding v = idArity v == 0
- | otherwise = True
+exprIsTrivial (Var v) = True
exprIsTrivial (Type _) = True
exprIsTrivial (Lit lit) = True
exprIsTrivial (App e arg) = isTypeArg arg && exprIsTrivial e
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 (nilOL, mkLams bndrs' body')
where
(bndrs,body) = collectBinders expr
where
stricts = case idNewStrictness v of
StrictSig (DmdType _ demands _)
- | depth >= length demands -> demands
- | otherwise -> []
+ | 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")
-- non-variable fun, better let-bind it
collect_args fun depth
= corePrepExprFloat env fun `thenUs` \ (fun_floats, fun') ->
- newVar ty (exprArity fun') `thenUs` \ fn_id ->
+ 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
-- because floating the case would make it evaluated too early
--
-- Finally, eta-expand the RHS, for the benefit of the code gen
- etaExpandRhs bndr rhs `thenUs` \ rhs' ->
- returnUs (floats, rhs')
+ returnUs (floats, rhs)
| otherwise
-- Don't float; the RHS isn't a value
= mkBinds floats rhs `thenUs` \ rhs' ->
- etaExpandRhs bndr rhs' `thenUs` \ rhs'' ->
- returnUs (nilOL, rhs'')
+ returnUs (nilOL, rhs')
-- mkLocalNonRec is used only for *nested*, *non-recursive* bindings
mkLocalNonRec :: Id -> RhsDemand -- Lhs: id with demand
= floatRhs NotTopLevel NonRecursive bndr (floats, rhs) `thenUs` \ (floats', rhs') ->
returnUs (floats' `snocOL` FloatLet (NonRec bndr rhs'))
+ where
+ bndr_ty = idType bndr
+ bndr_rep_ty = repType bndr_ty
+
mkBinds :: OrdList FloatingBind -> CoreExpr -> UniqSM CoreExpr
mkBinds binds body
| isNilOL binds = returnUs body
-- 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 (idArity bndr) us rhs (idType bndr))
+ 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)
| otherwise
= case tryEta bndrs body of
Just no_lam_result -> returnUs no_lam_result
- Nothing -> newVar (exprType expr) (exprArity expr) `thenUs` \ fn ->
+ Nothing -> newVar (exprType expr) `thenUs` \ fn ->
returnUs (Let (NonRec fn expr) (Var fn))
where
(bndrs,body) = collectBinders expr
cloneBndr :: CloneEnv -> Var -> UniqSM (CloneEnv, Var)
cloneBndr env bndr
- | isGlobalId bndr -- Top level things, which we don't want
- = returnUs (env, bndr) -- to clone, have become GlobalIds by now
-
- | otherwise
+ | isLocalId bndr
= getUniqueUs `thenUs` \ uniq ->
let
bndr' = setVarUnique bndr uniq
in
returnUs (extendVarEnv 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
-- Generating new binders
-- ---------------------------------------------------------------------------
-newVar :: Type -> Arity -> UniqSM Id
--- We're creating a new let binder, and we must give
--- it the right arity for the benefit of the code generator.
-newVar ty arity
+newVar :: Type -> UniqSM Id
+newVar ty
= seqType ty `seq`
getUniqueUs `thenUs` \ uniq ->
- returnUs (mkSysLocal SLIT("sat") uniq ty
- `setIdArity` arity)
+ returnUs (mkSysLocal SLIT("sat") uniq ty)
\end{code}
projects / ghc-hetmet.git / blobdiff