X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FstgSyn%2FCoreToStg.lhs;h=c69ae3720d43c53454e7a69b145f511823079225;hb=ea659be5faea43df1b2c113d2f22947dff23367e;hp=8db87aad8175cf37a215a147f9ee62a30f2d3ddb;hpb=451a8613203721d344e26eb043e8af827c58cd7b;p=ghc-hetmet.git diff --git a/ghc/compiler/stgSyn/CoreToStg.lhs b/ghc/compiler/stgSyn/CoreToStg.lhs index 8db87aa..c69ae37 100644 --- a/ghc/compiler/stgSyn/CoreToStg.lhs +++ b/ghc/compiler/stgSyn/CoreToStg.lhs @@ -17,28 +17,28 @@ module CoreToStg ( topCoreBindsToStg ) where 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 ) -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(..) ) +import BasicTypes ( TopLevelFlag(..), isNotTopLevel ) +import UniqSet ( emptyUniqSet ) import Maybes import Outputable \end{code} @@ -141,12 +141,20 @@ mkDemTy :: Demand -> Type -> RhsDemand 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 @@ -157,12 +165,15 @@ No free/live variable information is pinned on in this pass; it's added later. For this pass we use @bOGUS_LVs@ and @bOGUS_FVs@ as placeholders. +When printing out the Stg we need non-bottom values in these +locations. + \begin{code} bOGUS_LVs :: StgLiveVars -bOGUS_LVs = panic "bOGUS_LVs" -- emptyUniqSet (used when pprTracing) +bOGUS_LVs = emptyUniqSet bOGUS_FVs :: [Id] -bOGUS_FVs = panic "bOGUS_FVs" -- [] (ditto) +bOGUS_FVs = [] \end{code} \begin{code} @@ -186,7 +197,8 @@ topCoreBindsToStg us core_binds ppr b ) -- No top-level cases! mkStgBinds floats rhs `thenUs` \ new_rhs -> - returnUs (StgNonRec bndr (exprToRhs dem new_rhs) : new_bs) + returnUs (StgNonRec bndr (exprToRhs dem TopLevel new_rhs) + : new_bs) -- Keep all the floats inside... -- Some might be cases etc -- We might want to revisit this decision @@ -207,7 +219,7 @@ topCoreBindsToStg us core_binds 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) @@ -222,18 +234,17 @@ coreBindToStg top_lev env (NonRec binder rhs) 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 stg_expr') - where - dem = bdrDem bndr + returnUs (exprToRhs (bdrDem bndr) top_lev stg_expr') \end{code} @@ -244,8 +255,8 @@ coreBindToStg top_lev env (Rec pairs) %************************************************************************ \begin{code} -exprToRhs :: RhsDemand -> StgExpr -> StgRhs -exprToRhs dem (StgLam _ bndrs body) +exprToRhs :: RhsDemand -> TopLevelFlag -> StgExpr -> StgRhs +exprToRhs dem _ (StgLam _ bndrs body) = ASSERT( not (null bndrs) ) StgRhsClosure noCCS stgArgOcc @@ -259,8 +270,8 @@ exprToRhs dem (StgLam _ bndrs body) 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 @@ -285,43 +296,37 @@ exprToRhs dem (StgLam _ bndrs body) constructors (ala C++ static class constructors) which will then be run at load time to fix up static closures. -} -exprToRhs dem (StgCon (DataCon con) args _) - | 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} @@ -348,14 +353,19 @@ coreArgToStg :: StgEnv -> (CoreArg,RhsDemand) -> UniqSM ([StgFloatBind], StgArg) -- 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} @@ -366,9 +376,9 @@ coreArgToStg env (arg,dem) %************************************************************************ \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} @@ -381,41 +391,40 @@ coreExprToStg env expr dem \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 (Lit lit) + = returnUs ([], StgLit lit) -coreExprToStgFloat env (Let bind body) dem +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} @@ -427,30 +436,28 @@ coreExprToStgFloat env expr@(Type _) dem %************************************************************************ \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} @@ -461,29 +468,36 @@ coreExprToStgFloat env expr@(Lam _ _) dem %************************************************************************ \begin{code} -coreExprToStgFloat env expr@(App _ _) dem +coreExprToStgFloat env expr@(App _ _) = let - (fun,rads,_,_) = collect_args expr - ads = reverse rads + (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 + -- so we have to ignore all the strictness info + -- e.g. + (error "urk") + -- Here, we can't evaluate the arg strictly, + -- because this partial application might be seq'd in - coreArgsToStg env ads `thenUs` \ (arg_floats, stg_args) -> + coreArgsToStg env final_ads `thenUs` \ (arg_floats, stg_args) -> -- 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*) @@ -499,17 +513,15 @@ coreExprToStgFloat env expr@(App _ _) dem 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 (App fun arg) - = case ss of - [] -> -- Strictness info has run out - (the_fun, (arg, mkDemTy wwLazy arg_ty) : zap ads, res_ty, repeat wwLazy) - (ss1:ss_rest) -> -- Enough strictness info - (the_fun, (arg, mkDemTy ss1 arg_ty) : ads, res_ty, ss_rest) + = (the_fun, (arg, mkDemTy ss1 arg_ty) : ads, res_ty, ss_rest) where + (ss1, ss_rest) = case ss of + (ss1:ss_rest) -> (ss1, ss_rest) + [] -> (wwLazy, []) (the_fun, ads, fun_ty, ss) = collect_args fun (arg_ty, res_ty) = expectJust "coreExprToStgFloat:collect_args" $ splitFunTy_maybe fun_ty @@ -517,64 +529,16 @@ coreExprToStgFloat env expr@(App _ _) dem 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} - %************************************************************************ %* * @@ -582,43 +546,13 @@ coreExprToStgFloat env expr@(Con con args) dem %* * %************************************************************************ -Mangle cases involving seq# in the discriminant. Up to this -point, seq# will appear like this: - - case seq# e of - 0# -> seqError# - _ -> ... - -where the 0# branch is purely to bamboozle the strictness analyser -This code comes from an unfolding for 'seq' in Prelude.hs. We -translate this into - - case e of - _ -> ... - -Now that the evaluation order is safe. - -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. - \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 -\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) @@ -627,32 +561,31 @@ coreExprToStgFloat env (Case scrut bndr alts) dem | 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} @@ -665,49 +598,41 @@ coreExprToStgFloat env (Case scrut bndr alts) dem 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 [] @@ -719,15 +644,94 @@ newLocalIds top_lev env (b: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 @@ -737,6 +741,52 @@ mkStgLamExpr ty bndrs body 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 @@ -764,16 +814,16 @@ mkStgBind (NonRecF bndr rhs dem floats) body mk_stg_let bndr rhs dem floats body #endif - | isUnLiftedType bndr_ty -- Use a case/PrimAlts - = ASSERT( not (isUnboxedTupleType bndr_ty) ) - mkStgBinds floats $ - mkStgCase rhs bndr (StgPrimAlts bndr_ty [] (StgBindDefault body)) + | isUnLiftedType bndr_rep_ty -- Use a case/PrimAlts + = ASSERT( not (isUnboxedTupleType bndr_rep_ty) ) + mkStgCase rhs bndr (mkStgPrimAlts bndr_rep_ty [] (StgBindDefault body)) `thenUs` \ expr' -> + mkStgBinds floats expr' | is_whnf = if is_strict then -- Strict let with WHNF rhs mkStgBinds floats $ - StgLet (StgNonRec bndr (exprToRhs dem rhs)) body + StgLet (StgNonRec bndr (exprToRhs dem NotTopLevel rhs)) body else -- Lazy let with WHNF rhs; float until we find a strict binding let @@ -781,25 +831,25 @@ mk_stg_let bndr rhs dem floats body in mkStgBinds floats_in rhs `thenUs` \ new_rhs -> mkStgBinds floats_out $ - StgLet (StgNonRec bndr (exprToRhs dem new_rhs)) body + StgLet (StgNonRec bndr (exprToRhs dem NotTopLevel new_rhs)) body | otherwise -- Not WHNF = if is_strict then -- Strict let with non-WHNF rhs - mkStgBinds floats $ - mkStgCase rhs bndr (StgAlgAlts bndr_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 -> - returnUs (StgLet (StgNonRec bndr (exprToRhs dem new_rhs)) body) + returnUs (StgLet (StgNonRec bndr (exprToRhs dem NotTopLevel new_rhs)) body) where - bndr_ty = idType bndr - is_strict = isStrictDem dem - is_whnf = case rhs of - StgCon _ _ _ -> True - StgLam _ _ _ -> True - other -> False + bndr_rep_ty = repType (idType bndr) + is_strict = isStrictDem dem + is_whnf = case rhs of + StgConApp _ _ -> True + StgLam _ _ _ -> True + other -> False -- Split at the first strict binding splitFloats fs@(NonRecF _ _ dem _ : _) @@ -809,12 +859,91 @@ splitFloats (f : fs) = case splitFloats fs of (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# + _ -> + +This code comes from an unfolding for 'seq' in Prelude.hs. +The 0# branch is purely to bamboozle the strictness analyser. +For example, if 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}