Convert a @CoreSyntax@ program to a @StgSyntax@ program.
\begin{code}
-module CoreToStg ( topCoreBindsToStg ) where
+module CoreToStg ( topCoreBindsToStg, coreToStgExpr ) where
#include "HsVersions.h"
import CoreSyn -- input
import StgSyn -- output
-import CoreUtils ( coreExprType )
+import CoreUtils ( exprType )
import SimplUtils ( findDefault )
import CostCentre ( noCCS )
-import Id ( Id, mkSysLocal, idType, getIdStrictness, idUnique, isExportedId,
- externallyVisibleId, setIdUnique, idName, getIdDemandInfo, setIdType
+import Id ( Id, mkSysLocal, idType, idStrictness, isExportedId,
+ mkVanillaId, idName, idDemandInfo, idArity, setIdType,
+ idFlavour
)
-import Var ( Var, varType, modifyIdInfo )
-import IdInfo ( setDemandInfo, StrictnessInfo(..) )
-import UsageSPUtils ( primOpUsgTys )
-import DataCon ( DataCon, dataConName, dataConId )
-import Demand ( Demand, isStrict, wwStrict, wwLazy )
-import Name ( Name, nameModule, isLocallyDefinedName )
-import Module ( isDynamicModule )
-import Const ( Con(..), Literal(..), isLitLitLit, conStrictness, isWHNFCon )
+import IdInfo ( StrictnessInfo(..), IdFlavour(..) )
+import DataCon ( dataConWrapId, dataConTyCon )
+import TyCon ( isAlgTyCon )
+import Demand ( Demand, isStrict, wwLazy )
+import Name ( setNameUnique )
import VarEnv
-import PrimOp ( PrimOp(..), primOpUsg, primOpSig )
+import PrimOp ( PrimOp(..), setCCallUnique )
import Type ( isUnLiftedType, isUnboxedTupleType, Type, splitFunTy_maybe,
- UsageAnn(..), tyUsg, applyTy, mkUsgTy, repType )
-import TysPrim ( intPrimTy )
+ applyTy, repType, seqType, splitTyConApp_maybe, splitTyConApp,
+ splitRepFunTys, mkFunTys,
+ uaUTy, usOnce, usMany, isTyVarTy
+ )
import UniqSupply -- all of it, really
-import Util ( lengthExceeds )
import BasicTypes ( TopLevelFlag(..), isNotTopLevel )
-import CmdLineOpts ( opt_D_verbose_stg2stg )
import UniqSet ( emptyUniqSet )
+import ErrUtils ( showPass, dumpIfSet_dyn )
+import CmdLineOpts ( DynFlags, DynFlag(..) )
import Maybes
import Outputable
\end{code}
are globally unique, not simply not-in-scope, which is all that
the simplifier ensures.
+4. If we are going to do object-file splitting, we make ALL top-level
+ names into Globals. Why?
+
+ In certain (prelude only) modules we split up the .hc file into
+ lots of separate little files, which are separately compiled by the C
+ compiler. That gives lots of little .o files. The idea is that if
+ you happen to mention one of them you don't necessarily pull them all
+ in. (Pulling in a piece you don't need can be v bad, because it may
+ mention other pieces you don't need either, and so on.)
+
+ Sadly, splitting up .hc files means that local names (like s234) are
+ now globally visible, which can lead to clashes between two .hc
+ files. So we make them all Global, so they are printed complete
+ with their module name.
+
+ We don't want to do this in CoreTidy, because at that stage we use
+ Global to mean "external" and hence "should appear in interface files".
+ This object-file splitting thing is a code generator matter that we
+ don't want to pollute earlier phases.
NOTE THAT:
mkDemTy strict ty = RhsDemand (isStrict strict) (isOnceTy ty)
isOnceTy :: Type -> Bool
-isOnceTy ty = case tyUsg ty of
- UsOnce -> True
- UsMany -> False
+isOnceTy ty
+ =
+#ifdef USMANY
+ opt_UsageSPOn && -- can't expect annotations if -fusagesp is off
+#endif
+ once
+ where
+ u = uaUTy ty
+ once | u == usOnce = True
+ | u == usMany = False
+ | isTyVarTy u = False -- if unknown at compile-time, is Top ie usMany
bdrDem :: Id -> RhsDemand
-bdrDem id = mkDem (getIdDemandInfo id) (isOnceTy (idType id))
+bdrDem id = mkDem (idDemandInfo id) (isOnceTy (idType id))
safeDem, onceDem :: RhsDemand
safeDem = RhsDemand False False -- always safe to use this
\begin{code}
bOGUS_LVs :: StgLiveVars
-bOGUS_LVs | opt_D_verbose_stg2stg = emptyUniqSet
- | otherwise =panic "bOGUS_LVs"
+bOGUS_LVs = emptyUniqSet
bOGUS_FVs :: [Id]
-bOGUS_FVs | opt_D_verbose_stg2stg = []
- | otherwise = panic "bOGUS_FVs"
+bOGUS_FVs = []
\end{code}
\begin{code}
-topCoreBindsToStg :: UniqSupply -- name supply
- -> [CoreBind] -- input
- -> [StgBinding] -- output
-
-topCoreBindsToStg us core_binds
- = initUs_ us (coreBindsToStg emptyVarEnv core_binds)
+topCoreBindsToStg :: DynFlags -> [CoreBind] -> IO [StgBinding]
+topCoreBindsToStg dflags core_binds
+ = do showPass dflags "Core2Stg"
+ us <- mkSplitUniqSupply 'c'
+ return (initUs_ us (coreBindsToStg emptyVarEnv core_binds))
where
coreBindsToStg :: StgEnv -> [CoreBind] -> UniqSM [StgBinding]
returnUs new_bs
\end{code}
+%************************************************************************
+%* *
+\subsection[coreToStgExpr]{Converting an expression (for the interpreter)}
+%* *
+%************************************************************************
+
+\begin{code}
+coreToStgExpr :: DynFlags -> CoreExpr -> IO StgExpr
+coreToStgExpr dflags core_expr
+ = do showPass dflags "Core2Stg"
+ us <- mkSplitUniqSupply 'c'
+ let stg_expr = initUs_ us (coreExprToStg emptyVarEnv core_expr)
+ dumpIfSet_dyn dflags Opt_D_dump_stg "STG syntax:" (ppr stg_expr)
+ return stg_expr
+\end{code}
%************************************************************************
%* *
coreBindToStg :: TopLevelFlag -> StgEnv -> CoreBind -> UniqSM (StgFloatBind, StgEnv)
coreBindToStg top_lev env (NonRec binder rhs)
- = coreExprToStgFloat env rhs dem `thenUs` \ (floats, stg_rhs) ->
+ = coreExprToStgFloat env rhs `thenUs` \ (floats, stg_rhs) ->
case (floats, stg_rhs) of
([], StgApp var []) | not (isExportedId binder)
-> returnUs (NoBindF, extendVarEnv env binder var)
where
dem = bdrDem binder
+
coreBindToStg top_lev env (Rec pairs)
= newLocalIds top_lev env binders `thenUs` \ (env', binders') ->
mapUs (do_rhs env') pairs `thenUs` \ stg_rhss ->
returnUs (RecF (binders' `zip` stg_rhss), env')
where
binders = map fst pairs
- do_rhs env (bndr,rhs) = coreExprToStgFloat env rhs dem `thenUs` \ (floats, stg_expr) ->
+ do_rhs env (bndr,rhs) = coreExprToStgFloat env rhs `thenUs` \ (floats, stg_expr) ->
mkStgBinds floats stg_expr `thenUs` \ stg_expr' ->
-- NB: stg_expr' might still be a StgLam (and we want that)
- returnUs (exprToRhs dem top_lev stg_expr')
- where
- dem = bdrDem bndr
+ returnUs (exprToRhs (bdrDem bndr) top_lev stg_expr')
\end{code}
We reject the following candidates for 'static constructor'dom:
- any dcon that takes a lit-lit as an arg.
- - [Win32 DLLs only]: any dcon that is (or takes as arg)
- that's living in a DLL.
+ - [Win32 DLLs only]: any dcon that resides in a DLL
+ (or takes as arg something that is.)
These constraints are necessary to ensure that the code
generated in the end for the static constructors, which
constructors (ala C++ static class constructors) which will
then be run at load time to fix up static closures.
-}
-exprToRhs dem toplev (StgCon (DataCon con) args _)
- | isNotTopLevel toplev ||
- (not is_dynamic &&
- all (not.is_lit_lit) args) = StgRhsCon noCCS con args
- where
- is_dynamic = isDynCon con || any (isDynArg) args
-
- is_lit_lit (StgVarArg _) = False
- is_lit_lit (StgConArg x) =
- case x of
- Literal l -> isLitLitLit l
- _ -> False
-
-exprToRhs dem _ expr
- = StgRhsClosure noCCS -- No cost centre (ToDo?)
- stgArgOcc -- safe
+exprToRhs dem toplev (StgConApp con args)
+ | isNotTopLevel toplev || not (isDllConApp con args)
+ -- isDllConApp checks for LitLit args too
+ = StgRhsCon noCCS con args
+
+exprToRhs dem toplev expr
+ = upd `seq`
+ StgRhsClosure noCCS -- No cost centre (ToDo?)
+ stgArgOcc -- safe
noSRT -- figure out later
bOGUS_FVs
- (if isOnceDem dem then SingleEntry else Updatable)
- -- HA! Paydirt for "dem"
+ upd
[]
expr
-
-isDynCon :: DataCon -> Bool
-isDynCon con = isDynName (dataConName con)
-
-isDynArg :: StgArg -> Bool
-isDynArg (StgVarArg v) = isDynName (idName v)
-isDynArg (StgConArg con) =
- case con of
- DataCon dc -> isDynCon dc
- Literal l -> isLitLitLit l
- _ -> False
-
-isDynName :: Name -> Bool
-isDynName nm =
- not (isLocallyDefinedName nm) &&
- isDynamicModule (nameModule nm)
+ where
+ upd = if isOnceDem dem
+ then (if isNotTopLevel toplev
+ then SingleEntry -- HA! Paydirt for "dem"
+ else
+#ifdef DEBUG
+ trace "WARNING: SE CAFs unsupported, forcing UPD instead" $
+#endif
+ Updatable)
+ else Updatable
+ -- For now we forbid SingleEntry CAFs; they tickle the
+ -- ASSERT in rts/Storage.c line 215 at newCAF() re mut_link,
+ -- and I don't understand why. There's only one SE_CAF (well,
+ -- only one that tickled a great gaping bug in an earlier attempt
+ -- at ClosureInfo.getEntryConvention) in the whole of nofib,
+ -- specifically Main.lvl6 in spectral/cryptarithm2.
+ -- So no great loss. KSW 2000-07.
\end{code}
-- This is where we arrange that a non-trivial argument is let-bound
coreArgToStg env (arg,dem)
- = coreExprToStgFloat env arg dem `thenUs` \ (floats, arg') ->
+ = coreExprToStgFloat env arg `thenUs` \ (floats, arg') ->
case arg' of
- StgCon con [] _ -> returnUs (floats, StgConArg con)
- StgApp v [] -> returnUs (floats, StgVarArg v)
- other -> newStgVar arg_ty `thenUs` \ v ->
- returnUs ([NonRecF v arg' dem floats], StgVarArg v)
+ StgApp v [] -> returnUs (floats, StgVarArg v)
+ StgLit lit -> returnUs (floats, StgLitArg lit)
+
+ StgConApp con [] -> returnUs (floats, StgVarArg (dataConWrapId con))
+ -- A nullary constructor can be replaced with
+ -- a ``call'' to its wrapper
+
+ other -> newStgVar arg_ty `thenUs` \ v ->
+ returnUs ([NonRecF v arg' dem floats], StgVarArg v)
where
- arg_ty = coreExprType arg
+ arg_ty = exprType arg
\end{code}
%************************************************************************
\begin{code}
-coreExprToStg :: StgEnv -> CoreExpr -> RhsDemand -> UniqSM StgExpr
-coreExprToStg env expr dem
- = coreExprToStgFloat env expr dem `thenUs` \ (binds,stg_expr) ->
+coreExprToStg :: StgEnv -> CoreExpr -> UniqSM StgExpr
+coreExprToStg env expr
+ = coreExprToStgFloat env expr `thenUs` \ (binds,stg_expr) ->
mkStgBinds binds stg_expr `thenUs` \ stg_expr' ->
deStgLam stg_expr'
\end{code}
\begin{code}
coreExprToStgFloat :: StgEnv -> CoreExpr
- -> RhsDemand
-> UniqSM ([StgFloatBind], StgExpr)
--- Transform an expression to STG. The demand on the expression is
--- given by RhsDemand, and is solely used ot figure out the usage
--- of constructor args: if the constructor is used once, then so are
--- its arguments. The strictness info in RhsDemand isn't used.
-
--- The StgExpr returned *can* be an StgLam
+-- Transform an expression to STG. The 'floats' are
+-- any bindings we had to create for function arguments.
\end{code}
Simple cases first
\begin{code}
-coreExprToStgFloat env (Var var) dem
- = returnUs ([], StgApp (stgLookup env var) [])
+coreExprToStgFloat env (Var var)
+ = mkStgApp env var [] (idType var) `thenUs` \ app ->
+ returnUs ([], app)
-coreExprToStgFloat env (Let bind body) dem
+coreExprToStgFloat env (Lit lit)
+ = returnUs ([], StgLit lit)
+
+coreExprToStgFloat env (Let bind body)
= coreBindToStg NotTopLevel env bind `thenUs` \ (new_bind, new_env) ->
- coreExprToStgFloat new_env body dem `thenUs` \ (floats, stg_body) ->
+ coreExprToStgFloat new_env body `thenUs` \ (floats, stg_body) ->
returnUs (new_bind:floats, stg_body)
\end{code}
Convert core @scc@ expression directly to STG @scc@ expression.
\begin{code}
-coreExprToStgFloat env (Note (SCC cc) expr) dem
- = coreExprToStg env expr dem `thenUs` \ stg_expr ->
+coreExprToStgFloat env (Note (SCC cc) expr)
+ = coreExprToStg env expr `thenUs` \ stg_expr ->
returnUs ([], StgSCC cc stg_expr)
-coreExprToStgFloat env (Note other_note expr) dem
- = coreExprToStgFloat env expr dem
+coreExprToStgFloat env (Note other_note expr)
+ = coreExprToStgFloat env expr
\end{code}
\begin{code}
-coreExprToStgFloat env expr@(Type _) dem
+coreExprToStgFloat env expr@(Type _)
= pprPanic "coreExprToStgFloat: tyarg unexpected:" $ ppr expr
\end{code}
%************************************************************************
\begin{code}
-coreExprToStgFloat env expr@(Lam _ _) dem
+coreExprToStgFloat env expr@(Lam _ _)
= let
- expr_ty = coreExprType expr
+ expr_ty = exprType expr
(binders, body) = collectBinders expr
id_binders = filter isId binders
- body_dem = trace "coreExprToStg: approximating body_dem in Lam"
- safeDem
in
- if null id_binders then -- It was all type/usage binders; tossed
- coreExprToStgFloat env body dem
+ if null id_binders then -- It was all type binders; tossed
+ coreExprToStgFloat env body
else
-- At least some value binders
newLocalIds NotTopLevel env id_binders `thenUs` \ (env', binders') ->
- coreExprToStgFloat env' body body_dem `thenUs` \ (floats, stg_body) ->
+ coreExprToStgFloat env' body `thenUs` \ (floats, stg_body) ->
mkStgBinds floats stg_body `thenUs` \ stg_body' ->
case stg_body' of
StgLam ty lam_bndrs lam_body ->
-- If the body reduced to a lambda too, join them up
- returnUs ([], StgLam expr_ty (binders' ++ lam_bndrs) lam_body)
+ returnUs ([], mkStgLam expr_ty (binders' ++ lam_bndrs) lam_body)
other ->
-- Body didn't reduce to a lambda, so return one
- returnUs ([], StgLam expr_ty binders' stg_body')
+ returnUs ([], mkStgLam expr_ty binders' stg_body')
\end{code}
%************************************************************************
\begin{code}
-coreExprToStgFloat env expr@(App _ _) dem
+coreExprToStgFloat env expr@(App _ _)
= let
- (fun,rads,_,ss) = collect_args expr
+ (fun,rads,ty,ss) = collect_args expr
ads = reverse rads
final_ads | null ss = ads
| otherwise = zap ads -- Too few args to satisfy strictness info
-- Now deal with the function
case (fun, stg_args) of
- (Var fun_id, _) -> -- A function Id, so do an StgApp; it's ok if
+ (Var fn_id, _) -> -- A function Id, so do an StgApp; it's ok if
-- there are no arguments.
- returnUs (arg_floats,
- StgApp (stgLookup env fun_id) stg_args)
+ mkStgApp env fn_id stg_args ty `thenUs` \ app ->
+ returnUs (arg_floats, app)
(non_var_fun, []) -> -- No value args, so recurse into the function
ASSERT( null arg_floats )
- coreExprToStgFloat env non_var_fun dem
+ coreExprToStgFloat env non_var_fun
other -> -- A non-variable applied to things; better let-bind it.
- newStgVar (coreExprType fun) `thenUs` \ fun_id ->
- coreExprToStgFloat env fun onceDem `thenUs` \ (fun_floats, stg_fun) ->
- returnUs (NonRecF fun_id stg_fun onceDem fun_floats : arg_floats,
- StgApp fun_id stg_args)
+ newStgVar (exprType fun) `thenUs` \ fn_id ->
+ coreExprToStgFloat env fun `thenUs` \ (fun_floats, stg_fun) ->
+ mkStgApp env fn_id stg_args ty `thenUs` \ app ->
+ returnUs (NonRecF fn_id stg_fun onceDem fun_floats : arg_floats,
+ app)
where
-- Collect arguments and demands (*in reverse order*)
collect_args (Note (Coerce ty _) e) = let (the_fun,ads,_,ss) = collect_args e
in (the_fun,ads,ty,ss)
collect_args (Note InlineCall e) = collect_args e
- collect_args (Note (TermUsg _) e) = collect_args e
collect_args (App fun (Type tyarg)) = let (the_fun,ads,fun_ty,ss) = collect_args fun
in (the_fun,ads,applyTy fun_ty tyarg,ss)
collect_args (Var v)
= (Var v, [], idType v, stricts)
where
- stricts = case getIdStrictness v of
+ stricts = case idStrictness v of
StrictnessInfo demands _ -> demands
other -> repeat wwLazy
- collect_args fun = (fun, [], coreExprType fun, repeat wwLazy)
+ collect_args fun = (fun, [], exprType fun, repeat wwLazy)
-- "zap" nukes the strictness info for a partial application
zap ads = [(arg, RhsDemand False once) | (arg, RhsDemand _ once) <- ads]
\end{code}
-%************************************************************************
-%* *
-\subsubsection[coreToStg-con]{Constructors and primops}
-%* *
-%************************************************************************
-
-For data constructors, the demand on an argument is the demand on the
-constructor as a whole (see module UsageSPInf). For primops, the
-demand is derived from the type of the primop.
-
-If usage inference is off, we simply make all bindings updatable for
-speed.
-
-\begin{code}
-coreExprToStgFloat env expr@(Con con args) dem
- = let
- (stricts,_) = conStrictness con
- onces = case con of
- DEFAULT -> panic "coreExprToStgFloat: DEFAULT"
-
- Literal _ -> ASSERT( null args' {-'cpp-} ) []
-
- DataCon c -> repeat (isOnceDem dem)
- -- HA! This is the sole reason we propagate
- -- dem all the way down
-
- PrimOp p -> let tyargs = map (\ (Type ty) -> ty) $
- takeWhile isTypeArg args
- (arg_tys,_) = primOpUsgTys p tyargs
- in ASSERT( length arg_tys == length args' {-'cpp-} )
- -- primops always fully applied, so == not >=
- map isOnceTy arg_tys
-
- dems' = zipWith mkDem stricts onces
- args' = filter isValArg args
- in
- coreArgsToStg env (zip args' dems') `thenUs` \ (arg_floats, stg_atoms) ->
-
- -- YUK YUK: must unique if present
- (case con of
- PrimOp (CCallOp (Right _) a b c) -> getUniqueUs `thenUs` \ u ->
- returnUs (PrimOp (CCallOp (Right u) a b c))
- _ -> returnUs con
- ) `thenUs` \ con' ->
-
- returnUs (arg_floats, StgCon con' stg_atoms (coreExprType expr))
-\end{code}
-
%************************************************************************
%* *
%* *
%************************************************************************
-First, two special cases. We mangle cases involving
- par# and seq#
-inthe scrutinee.
-
-Up to this point, seq# will appear like this:
-
- case seq# e of
- 0# -> seqError#
- _ -> <stuff>
-
-This code comes from an unfolding for 'seq' in Prelude.hs.
-The 0# branch is purely to bamboozle the strictness analyser.
-For example, if <stuff> is strict in x, and there was no seqError#
-branch, the strictness analyser would conclude that the whole expression
-was strict in x, and perhaps evaluate x first -- but that would be a DISASTER.
-
-Now that the evaluation order is safe, we translate this into
-
- case e of
- _ -> ...
-
-This used to be done in the post-simplification phase, but we need
-unfoldings involving seq# to appear unmangled in the interface file,
-hence we do this mangling here.
-
-Similarly, par# has an unfolding in PrelConc.lhs that makes it show
-up like this:
-
- case par# e of
- 0# -> rhs
- _ -> parError#
-
-
- ==>
- case par# e of
- _ -> rhs
-
-fork# isn't handled like this - it's an explicit IO operation now.
-The reason is that fork# returns a ThreadId#, which gets in the
-way of the above scheme. And anyway, IO is the only guaranteed
-way to enforce ordering --SDM.
-
-
-\begin{code}
-coreExprToStgFloat env
- (Case scrut@(Con (PrimOp SeqOp) [Type ty, e]) bndr alts) dem
- = coreExprToStgFloat env (Case e new_bndr [(DEFAULT,[],default_rhs)]) dem
- where
- new_bndr = setIdType bndr ty
- (other_alts, maybe_default) = findDefault alts
- Just default_rhs = maybe_default
-
-coreExprToStgFloat env
- (Case scrut@(Con (PrimOp ParOp) args) bndr alts) dem
- | maybeToBool maybe_default
- = coreExprToStgFloat env scrut (bdrDem bndr) `thenUs` \ (binds, scrut') ->
- newEvaldLocalId env bndr `thenUs` \ (env', bndr') ->
- coreExprToStg env' default_rhs dem `thenUs` \ default_rhs' ->
- returnUs (binds, mkStgCase scrut' bndr' (StgPrimAlts (idType bndr) [] (StgBindDefault default_rhs')))
- where
- (other_alts, maybe_default) = findDefault alts
- Just default_rhs = maybe_default
-\end{code}
-
-Now for normal case expressions...
-
\begin{code}
-coreExprToStgFloat env (Case scrut bndr alts) dem
- = coreExprToStgFloat env scrut (bdrDem bndr) `thenUs` \ (binds, scrut') ->
- newEvaldLocalId env bndr `thenUs` \ (env', bndr') ->
+coreExprToStgFloat env (Case scrut bndr alts)
+ = coreExprToStgFloat env scrut `thenUs` \ (binds, scrut') ->
+ newLocalId NotTopLevel env bndr `thenUs` \ (env', bndr') ->
alts_to_stg env' (findDefault alts) `thenUs` \ alts' ->
- returnUs (binds, mkStgCase scrut' bndr' alts')
+ mkStgCase scrut' bndr' alts' `thenUs` \ expr' ->
+ returnUs (binds, expr')
where
scrut_ty = idType bndr
prim_case = isUnLiftedType scrut_ty && not (isUnboxedTupleType scrut_ty)
| prim_case
= default_to_stg env deflt `thenUs` \ deflt' ->
mapUs (prim_alt_to_stg env) alts `thenUs` \ alts' ->
- returnUs (StgPrimAlts scrut_ty alts' deflt')
+ returnUs (mkStgPrimAlts scrut_ty alts' deflt')
| otherwise
= default_to_stg env deflt `thenUs` \ deflt' ->
mapUs (alg_alt_to_stg env) alts `thenUs` \ alts' ->
- returnUs (StgAlgAlts scrut_ty alts' deflt')
+ returnUs (mkStgAlgAlts scrut_ty alts' deflt')
- alg_alt_to_stg env (DataCon con, bs, rhs)
- = coreExprToStg env rhs dem `thenUs` \ stg_rhs ->
- returnUs (con, filter isId bs, [ True | b <- bs ]{-bogus use mask-}, stg_rhs)
+ alg_alt_to_stg env (DataAlt con, bs, rhs)
+ = newLocalIds NotTopLevel env (filter isId bs) `thenUs` \ (env', stg_bs) ->
+ coreExprToStg env' rhs `thenUs` \ stg_rhs ->
+ returnUs (con, stg_bs, [ True | b <- stg_bs ]{-bogus use mask-}, stg_rhs)
-- NB the filter isId. Some of the binders may be
-- existential type variables, which STG doesn't care about
- prim_alt_to_stg env (Literal lit, args, rhs)
+ prim_alt_to_stg env (LitAlt lit, args, rhs)
= ASSERT( null args )
- coreExprToStg env rhs dem `thenUs` \ stg_rhs ->
+ coreExprToStg env rhs `thenUs` \ stg_rhs ->
returnUs (lit, stg_rhs)
default_to_stg env Nothing
= returnUs StgNoDefault
default_to_stg env (Just rhs)
- = coreExprToStg env rhs dem `thenUs` \ stg_rhs ->
+ = coreExprToStg env rhs `thenUs` \ stg_rhs ->
returnUs (StgBindDefault stg_rhs)
- -- The binder is used for prim cases and not otherwise
- -- (hack for old code gen)
\end{code}
There's not anything interesting we can ASSERT about \tr{var} if it
isn't in the StgEnv. (WDP 94/06)
-\begin{code}
-stgLookup :: StgEnv -> Id -> Id
-stgLookup env var = case (lookupVarEnv env var) of
- Nothing -> var
- Just var -> var
-\end{code}
-
Invent a fresh @Id@:
\begin{code}
newStgVar :: Type -> UniqSM Id
newStgVar ty
= getUniqueUs `thenUs` \ uniq ->
+ seqType ty `seq`
returnUs (mkSysLocal SLIT("stg") uniq ty)
\end{code}
\begin{code}
--- we overload the demandInfo field of an Id to indicate whether the Id is definitely
--- evaluated or not (i.e. whether it is a case binder). This can be used to eliminate
--- some redundant cases (c.f. dataToTag# above).
-
-newEvaldLocalId env id
- = getUniqueUs `thenUs` \ uniq ->
- let
- id' = modifyIdInfo (`setDemandInfo` wwStrict) (setIdUnique id uniq)
- new_env = extendVarEnv env id id'
- in
- returnUs (new_env, id')
-
-
newLocalId TopLevel env id
- = returnUs (env, id)
-- Don't clone top-level binders. MkIface relies on their
-- uniques staying the same, so it can snaffle IdInfo off the
-- STG ids to put in interface files.
+ = let
+ name = idName id
+ ty = idType id
+ in
+ name `seq`
+ seqType ty `seq`
+ returnUs (env, mkVanillaId name ty)
+
newLocalId NotTopLevel env id
= -- Local binder, give it a new unique Id.
getUniqueUs `thenUs` \ uniq ->
let
- id' = setIdUnique id uniq
- new_env = extendVarEnv env id id'
+ name = idName id
+ ty = idType id
+ new_id = mkVanillaId (setNameUnique name uniq) ty
+ new_env = extendVarEnv env id new_id
in
- returnUs (new_env, id')
+ name `seq`
+ seqType ty `seq`
+ returnUs (new_env, new_id)
newLocalIds :: TopLevelFlag -> StgEnv -> [Id] -> UniqSM (StgEnv, [Id])
newLocalIds top_lev env []
= returnUs (env, [])
+
newLocalIds top_lev env (b:bs)
= newLocalId top_lev env b `thenUs` \ (env', b') ->
newLocalIds top_lev env' bs `thenUs` \ (env'', bs') ->
\end{code}
+%************************************************************************
+%* *
+\subsection{Building STG syn}
+%* *
+%************************************************************************
+
\begin{code}
--- Stg doesn't have a lambda *expression*,
-deStgLam (StgLam ty bndrs body) = mkStgLamExpr ty bndrs body
-deStgLam expr = returnUs expr
+-- There are two things going on in mkStgAlgAlts
+-- a) We pull out the type constructor for the case, from the data
+-- constructor, if there is one. See notes with the StgAlgAlts data type
+-- b) We force the type constructor to avoid space leaks
+
+mkStgAlgAlts ty alts deflt
+ = case alts of
+ -- Get the tycon from the data con
+ (dc, _, _, _):_ -> StgAlgAlts (Just (dataConTyCon dc)) alts deflt
+
+ -- Otherwise just do your best
+ [] -> case splitTyConApp_maybe (repType ty) of
+ Just (tc,_) | isAlgTyCon tc -> StgAlgAlts (Just tc) alts deflt
+ other -> StgAlgAlts Nothing alts deflt
+
+mkStgPrimAlts ty alts deflt
+ = case splitTyConApp ty of
+ (tc,_) -> StgPrimAlts tc alts deflt
+
+mkStgLam ty bndrs body = seqType ty `seq` StgLam ty bndrs body
+
+mkStgApp :: StgEnv -> Id -> [StgArg] -> Type -> UniqSM StgExpr
+ -- The type is the type of the entire application
+mkStgApp env fn args ty
+ = case idFlavour fn_alias of
+ DataConId dc
+ -> saturate fn_alias args ty $ \ args' ty' ->
+ returnUs (StgConApp dc args')
+
+ PrimOpId (CCallOp ccall)
+ -- Sigh...make a guaranteed unique name for a dynamic ccall
+ -- Done here, not earlier, because it's a code-gen thing
+ -> saturate fn_alias args ty $ \ args' ty' ->
+ getUniqueUs `thenUs` \ uniq ->
+ let ccall' = setCCallUnique ccall uniq in
+ returnUs (StgPrimApp (CCallOp ccall') args' ty')
+
+
+ PrimOpId op
+ -> saturate fn_alias args ty $ \ args' ty' ->
+ returnUs (StgPrimApp op args' ty')
+
+ other -> returnUs (StgApp fn_alias args)
+ -- Force the lookup
+ where
+ fn_alias = case (lookupVarEnv env fn) of -- In case it's been cloned
+ Nothing -> fn
+ Just fn' -> fn'
+
+saturate :: Id -> [StgArg] -> Type -> ([StgArg] -> Type -> UniqSM StgExpr) -> UniqSM StgExpr
+ -- The type should be the type of (id args)
+saturate fn args ty thing_inside
+ | excess_arity == 0 -- Saturated, so nothing to do
+ = thing_inside args ty
+
+ | otherwise -- An unsaturated constructor or primop; eta expand it
+ = ASSERT2( excess_arity > 0 && excess_arity <= length arg_tys,
+ ppr fn <+> ppr args <+> ppr excess_arity <+> parens (ppr ty) <+> ppr arg_tys )
+ mapUs newStgVar extra_arg_tys `thenUs` \ arg_vars ->
+ thing_inside (args ++ map StgVarArg arg_vars) final_res_ty `thenUs` \ body ->
+ returnUs (StgLam ty arg_vars body)
+ where
+ fn_arity = idArity fn
+ excess_arity = fn_arity - length args
+ (arg_tys, res_ty) = splitRepFunTys ty
+ extra_arg_tys = take excess_arity arg_tys
+ final_res_ty = mkFunTys (drop excess_arity arg_tys) res_ty
+\end{code}
-mkStgLamExpr ty bndrs body
+\begin{code}
+-- Stg doesn't have a lambda *expression*
+deStgLam (StgLam ty bndrs body)
+ -- Try for eta reduction
= ASSERT( not (null bndrs) )
- newStgVar ty `thenUs` \ fn ->
- returnUs (StgLet (StgNonRec fn lam_closure) (StgApp fn []))
+ case eta body of
+ Just e -> -- Eta succeeded
+ returnUs e
+
+ Nothing -> -- Eta failed, so let-bind the lambda
+ newStgVar ty `thenUs` \ fn ->
+ returnUs (StgLet (StgNonRec fn lam_closure) (StgApp fn []))
where
lam_closure = StgRhsClosure noCCS
stgArgOcc
bndrs
body
+ eta (StgApp f args)
+ | n_remaining >= 0 &&
+ and (zipWith ok bndrs last_args) &&
+ notInExpr bndrs remaining_expr
+ = Just remaining_expr
+ where
+ remaining_expr = StgApp f remaining_args
+ (remaining_args, last_args) = splitAt n_remaining args
+ n_remaining = length args - length bndrs
+
+ eta (StgLet bind@(StgNonRec b r) body)
+ | notInRhs bndrs r = case eta body of
+ Just e -> Just (StgLet bind e)
+ Nothing -> Nothing
+
+ eta _ = Nothing
+
+ ok bndr (StgVarArg arg) = bndr == arg
+ ok bndr other = False
+
+deStgLam expr = returnUs expr
+
+
+--------------------------------------------------
+notInExpr :: [Id] -> StgExpr -> Bool
+notInExpr vs (StgApp f args) = notInId vs f && notInArgs vs args
+notInExpr vs (StgLet (StgNonRec b r) body) = notInRhs vs r && notInExpr vs body
+notInExpr vs other = False -- Safe
+
+notInRhs :: [Id] -> StgRhs -> Bool
+notInRhs vs (StgRhsCon _ _ args) = notInArgs vs args
+notInRhs vs (StgRhsClosure _ _ _ _ _ _ body) = notInExpr vs body
+ -- Conservative: we could delete the binders from vs, but
+ -- cloning means this will never help
+
+notInArgs :: [Id] -> [StgArg] -> Bool
+notInArgs vs args = all ok args
+ where
+ ok (StgVarArg v) = notInId vs v
+ ok (StgLitArg l) = True
+
+notInId :: [Id] -> Id -> Bool
+notInId vs v = not (v `elem` vs)
+
+
+
mkStgBinds :: [StgFloatBind]
-> StgExpr -- *Can* be a StgLam
-> UniqSM StgExpr -- *Can* be a StgLam
#endif
| isUnLiftedType bndr_rep_ty -- Use a case/PrimAlts
= ASSERT( not (isUnboxedTupleType bndr_rep_ty) )
- mkStgBinds floats $
- mkStgCase rhs bndr (StgPrimAlts bndr_rep_ty [] (StgBindDefault body))
+ mkStgCase rhs bndr (mkStgPrimAlts bndr_rep_ty [] (StgBindDefault body)) `thenUs` \ expr' ->
+ mkStgBinds floats expr'
| is_whnf
= if is_strict then
| otherwise -- Not WHNF
= if is_strict then
-- Strict let with non-WHNF rhs
- mkStgBinds floats $
- mkStgCase rhs bndr (StgAlgAlts bndr_rep_ty [] (StgBindDefault body))
+ mkStgCase rhs bndr (mkStgAlgAlts bndr_rep_ty [] (StgBindDefault body)) `thenUs` \ expr' ->
+ mkStgBinds floats expr'
else
-- Lazy let with non-WHNF rhs, so keep the floats in the RHS
mkStgBinds floats rhs `thenUs` \ new_rhs ->
bndr_rep_ty = repType (idType bndr)
is_strict = isStrictDem dem
is_whnf = case rhs of
- StgCon _ _ _ -> True
- StgLam _ _ _ -> True
- other -> False
+ StgConApp _ _ -> True
+ StgLam _ _ _ -> True
+ other -> False
-- Split at the first strict binding
splitFloats fs@(NonRecF _ _ dem _ : _)
(fs_out, fs_in) -> (f : fs_out, fs_in)
splitFloats [] = ([], [])
+\end{code}
+
+
+Making an STG case
+~~~~~~~~~~~~~~~~~~
+
+First, two special cases. We mangle cases involving
+ par# and seq#
+inthe scrutinee.
+Up to this point, seq# will appear like this:
+
+ case seq# e of
+ 0# -> seqError#
+ _ -> <stuff>
+
+This code comes from an unfolding for 'seq' in Prelude.hs.
+The 0# branch is purely to bamboozle the strictness analyser.
+For example, if <stuff> is strict in x, and there was no seqError#
+branch, the strictness analyser would conclude that the whole expression
+was strict in x, and perhaps evaluate x first -- but that would be a DISASTER.
+
+Now that the evaluation order is safe, we translate this into
+
+ case e of
+ _ -> ...
+
+This used to be done in the post-simplification phase, but we need
+unfoldings involving seq# to appear unmangled in the interface file,
+hence we do this mangling here.
+
+Similarly, par# has an unfolding in PrelConc.lhs that makes it show
+up like this:
+
+ case par# e of
+ 0# -> rhs
+ _ -> parError#
+
+
+ ==>
+ case par# e of
+ _ -> rhs
+
+fork# isn't handled like this - it's an explicit IO operation now.
+The reason is that fork# returns a ThreadId#, which gets in the
+way of the above scheme. And anyway, IO is the only guaranteed
+way to enforce ordering --SDM.
+
+
+\begin{code}
+-- Discard alernatives in case (par# ..) of
+mkStgCase scrut@(StgPrimApp ParOp _ _) bndr
+ (StgPrimAlts tycon _ deflt@(StgBindDefault _))
+ = returnUs (StgCase scrut bOGUS_LVs bOGUS_LVs bndr noSRT (StgPrimAlts tycon [] deflt))
+
+mkStgCase (StgPrimApp SeqOp [scrut] _) bndr
+ (StgPrimAlts _ _ deflt@(StgBindDefault rhs))
+ = mkStgCase scrut_expr new_bndr new_alts
+ where
+ new_alts | isUnLiftedType scrut_ty = WARN( True, text "mkStgCase" ) mkStgPrimAlts scrut_ty [] deflt
+ | otherwise = mkStgAlgAlts scrut_ty [] deflt
+ scrut_ty = stgArgType scrut
+ new_bndr = setIdType bndr scrut_ty
+ -- 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.
+
+ scrut_expr = case scrut of
+ StgVarArg v -> StgApp v []
+ -- Others should not happen because
+ -- seq of a value should have disappeared
+ StgLitArg l -> WARN( True, text "seq on" <+> ppr l ) StgLit l
mkStgCase scrut bndr alts
- = ASSERT( case scrut of { StgLam _ _ _ -> False; other -> True } )
- -- We should never find
- -- case (\x->e) of { ... }
- -- The simplifier eliminates such things
- StgCase scrut bOGUS_LVs bOGUS_LVs bndr noSRT alts
+ = deStgLam scrut `thenUs` \ scrut' ->
+ -- It is (just) possible to get a lambda as a srutinee here
+ -- Namely: fromDyn (toDyn ((+1)::Int->Int)) False)
+ -- gives: case ...Bool == Int->Int... of
+ -- True -> case coerce Bool (\x -> + 1 x) of
+ -- True -> ...
+ -- False -> ...
+ -- False -> ...
+ -- The True branch of the outer case will never happen, of course.
+
+ returnUs (StgCase scrut' bOGUS_LVs bOGUS_LVs bndr noSRT alts)
\end{code}