import CoreFVs ( exprFreeVars )
import CoreLint ( endPass )
import CoreSyn
-import Type ( Type, applyTy, splitFunTy_maybe, isTyVarTy,
- isUnLiftedType, isUnboxedTupleType, repType, seqType )
+import Type ( Type, applyTy, splitFunTy_maybe,
+ isUnLiftedType, isUnboxedTupleType, seqType )
import NewDemand ( Demand, isStrictDmd, lazyDmd, StrictSig(..), DmdType(..) )
-import PrimOp ( PrimOp(..) )
import Var ( Var, Id, setVarUnique )
import VarSet
import VarEnv
import Id ( mkSysLocal, idType, idNewDemandInfo, idArity,
- setIdType, isPrimOpId_maybe, isFCallId, isGlobalId,
+ isFCallId, isGlobalId,
isLocalId, hasNoBinding, idNewStrictness,
isDataConId_maybe, idUnfolding
)
-import HscTypes ( ModDetails(..), implicitTyThingIds, typeEnvElts )
-import Unique ( mkBuiltinUnique )
+import HscTypes ( ModGuts(..), ModGuts, implicitTyThingIds, typeEnvElts )
import BasicTypes ( TopLevelFlag(..), isTopLevel, isNotTopLevel,
RecFlag(..), isNonRec
)
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
-- -----------------------------------------------------------------------------
\begin{code}
-corePrepPgm :: DynFlags -> ModDetails -> IO ModDetails
-corePrepPgm dflags mod_details
+corePrepPgm :: DynFlags -> ModGuts -> IO ModGuts
+corePrepPgm dflags mod_impl
= do showPass dflags "CorePrep"
us <- mkSplitUniqSupply 's'
- let implicit_binds = mkImplicitBinds (md_types mod_details)
+ let implicit_binds = mkImplicitBinds (mg_types mod_impl)
-- NB: we must feed mkImplicitBinds through corePrep too
-- so that they are suitably cloned and eta-expanded
binds_out = initUs_ us (
- corePrepTopBinds (md_binds mod_details) `thenUs` \ floats1 ->
- corePrepTopBinds implicit_binds `thenUs` \ floats2 ->
+ corePrepTopBinds (mg_binds mod_impl) `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 })
+ return (mod_impl { mg_binds = binds_out })
corePrepExpr :: DynFlags -> CoreExpr -> IO CoreExpr
corePrepExpr dflags expr
-- 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
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') ->
(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 `appOL` floats2 , Case scrut2 bndr' alts')
where
sat_alt env (con, bs, rhs)
= cloneBndrs env bs `thenUs` \ (env', bs') ->
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 ->
where
bndr_ty = idType bndr
- bndr_rep_ty = repType bndr_ty
+
mkBinds :: OrdList FloatingBind -> CoreExpr -> UniqSM CoreExpr
mkBinds binds body
| otherwise = deLam body `thenUs` \ body' ->
returnUs (foldrOL mk_bind body' binds)
where
- mk_bind (FloatCase bndr rhs _) body = mkCase rhs bndr [(DEFAULT, [], body)]
+ mk_bind (FloatCase bndr rhs _) body = Case rhs bndr [(DEFAULT, [], body)]
mk_bind (FloatLet bind) body = Let bind body
etaExpandRhs bndr rhs
-- 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 (OrdList FloatingBind, 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')
+ deLamFloat expr `thenUs` \ (floats, expr') ->
+ returnUs (floats, Note n expr')
-deLam expr
- | null bndrs = returnUs expr
+deLamFloat expr
+ | null bndrs = returnUs (nilOL, expr)
| otherwise
= case tryEta bndrs body of
- Just no_lam_result -> returnUs no_lam_result
+ Just no_lam_result -> returnUs (nilOL, no_lam_result)
Nothing -> newVar (exprType expr) `thenUs` \ fn ->
- returnUs (Let (NonRec fn expr) (Var fn))
+ returnUs (unitOL (FloatLet (NonRec fn expr)),
+ Var fn)
where
(bndrs,body) = collectBinders expr
-- -----------------------------------------------------------------------------
--- 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@(deflt_alt@(DEFAULT,_,rhs) : con_alts)
- -- DEFAULT alt is always first
- = 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
- -- 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
-- -----------------------------------------------------------------------------
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}
newVar ty
= seqType ty `seq`
getUniqueUs `thenUs` \ uniq ->
- returnUs (mkSysLocal SLIT("sat") uniq ty)
+ returnUs (mkSysLocal FSLIT("sat") uniq ty)
\end{code}