X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FstgSyn%2FCoreToStg.lhs;h=114131aeac3cfc186b3cbe23719a4631d7bade6a;hb=f7ecf7234c224489be8a5e63fced903b655d92ee;hp=4b21fb3a2a7e09102aa20b4f1ce7a82cbb8c1d7b;hpb=e7d21ee4f8ac907665a7e170c71d59e13a01da09;p=ghc-hetmet.git diff --git a/ghc/compiler/stgSyn/CoreToStg.lhs b/ghc/compiler/stgSyn/CoreToStg.lhs index 4b21fb3..114131a 100644 --- a/ghc/compiler/stgSyn/CoreToStg.lhs +++ b/ghc/compiler/stgSyn/CoreToStg.lhs @@ -1,5 +1,5 @@ % -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995 +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996 % %************************************************************************ %* * @@ -9,47 +9,46 @@ Convert a @CoreSyntax@ program to a @StgSyntax@ program. - \begin{code} #include "HsVersions.h" -module CoreToStg ( - topCoreBindsToStg, +module CoreToStg ( topCoreBindsToStg ) where - -- and to make the interface self-sufficient... - SplitUniqSupply, Id, CoreExpr, CoreBinding, StgBinding, - StgRhs, StgBinderInfo - ) where +IMP_Ubiq(){-uitous-} +IMPORT_1_3(Ratio(numerator,denominator)) -import PlainCore -- input -import AnnCoreSyn -- intermediate form on which all work is done +import CoreSyn -- input import StgSyn -- output -import SplitUniq -import Unique -- the UniqueSupply monadery used herein - -import AbsPrel ( unpackCStringId, stringTy, - integerTy, rationalTy, ratioDataCon, - PrimOp(..), -- For Int2IntegerOp etc - integerZeroId, integerPlusOneId, integerMinusOneId - IF_ATTACK_PRAGMAS(COMMA mkListTy COMMA charTy) - IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp) - IF_ATTACK_PRAGMAS(COMMA pprPrimOp) - ) -import AbsUniType ( isPrimType, isLeakFreeType, getUniDataTyCon ) -import Bag -- Bag operations -import BasicLit ( mkMachInt, BasicLit(..), PrimKind ) -- ToDo: its use is ugly... -import CostCentre ( noCostCentre, CostCentre ) -import Id ( mkSysLocal, getIdUniType, isBottomingId - IF_ATTACK_PRAGMAS(COMMA bottomIsGuaranteed) +import Bag ( emptyBag, unitBag, unionBags, unionManyBags, bagToList ) +import CoreUtils ( coreExprType ) +import CostCentre ( noCostCentre ) +import Id ( mkSysLocal, idType, isBottomingId, + externallyVisibleId, + nullIdEnv, addOneToIdEnv, lookupIdEnv, + SYN_IE(IdEnv), GenId{-instance NamedThing-} + ) +import Literal ( mkMachInt, Literal(..) ) +import PrelVals ( unpackCStringId, unpackCString2Id, + integerZeroId, integerPlusOneId, + integerPlusTwoId, integerMinusOneId ) -import IdEnv -import Maybes ( Maybe(..), catMaybes ) -import Outputable ( isExported ) -import Pretty -- debugging only! -import SpecTyFuns ( mkSpecialisedCon ) -import SrcLoc ( SrcLoc, mkUnknownSrcLoc ) -import Util +import PrimOp ( PrimOp(..) ) +import SpecUtils ( mkSpecialisedCon ) +import SrcLoc ( mkUnknownSrcLoc ) +import TyCon ( TyCon{-instance Uniquable-} ) +import Type ( maybeAppDataTyCon, getAppDataTyConExpandingDicts ) +import TysWiredIn ( stringTy ) +import Unique ( integerTyConKey, ratioTyConKey, Unique{-instance Eq-} ) +import UniqSupply -- all of it, really +import Util ( panic, assertPanic{-, pprTrace ToDo:rm-} ) +--import Pretty--ToDo:rm +--import PprStyle--ToDo:rm +--import PprType --ToDo:rm +--import Outputable--ToDo:rm +--import PprEnv--ToDo:rm + +isLeakFreeType x y = False -- safe option; ToDo \end{code} @@ -69,7 +68,7 @@ The business of this pass is to convert Core to Stg. On the way: * We do *not* pin on the correct free/live var info; that's done later. Instead we use bOGUS_LVS and _FVS as a placeholder. -* We convert case x of {...; x' -> ...x'...} +* We convert case x of {...; x' -> ...x'...} to case x of {...; _ -> ...x... } @@ -88,7 +87,7 @@ environment, so we can just replace all occurrences of \tr{x} with \tr{y}. \begin{code} -type StgEnv = IdEnv PlainStgAtom +type StgEnv = IdEnv StgArg \end{code} No free/live variable information is pinned on in this pass; it's added @@ -96,60 +95,66 @@ later. For this pass we use @bOGUS_LVs@ and @bOGUS_FVs@ as placeholders. \begin{code} -bOGUS_LVs :: PlainStgLiveVars -bOGUS_LVs = panic "bOGUS_LVs" +bOGUS_LVs :: StgLiveVars +bOGUS_LVs = panic "bOGUS_LVs" -- emptyUniqSet (used when pprTracing) bOGUS_FVs :: [Id] -bOGUS_FVs = panic "bOGUS_FVs" +bOGUS_FVs = panic "bOGUS_FVs" -- [] (ditto) \end{code} \begin{code} -topCoreBindsToStg :: SplitUniqSupply -- name supply - -> [PlainCoreBinding] -- input - -> [PlainStgBinding] -- output +topCoreBindsToStg :: UniqSupply -- name supply + -> [CoreBinding] -- input + -> [StgBinding] -- output topCoreBindsToStg us core_binds - = case (initSUs us (binds_to_stg nullIdEnv core_binds)) of + = case (initUs us (binds_to_stg nullIdEnv core_binds)) of (_, stuff) -> stuff where - binds_to_stg :: StgEnv -> [PlainCoreBinding] -> SUniqSM [PlainStgBinding] + binds_to_stg :: StgEnv -> [CoreBinding] -> UniqSM [StgBinding] - binds_to_stg env [] = returnSUs [] + binds_to_stg env [] = returnUs [] binds_to_stg env (b:bs) - = do_top_bind env b `thenSUs` \ (new_b, new_env, float_binds) -> - binds_to_stg new_env bs `thenSUs` \ new_bs -> - returnSUs (bagToList float_binds ++ -- Literals - new_b ++ - new_bs) + = do_top_bind env b `thenUs` \ (new_b, new_env, float_binds) -> + binds_to_stg new_env bs `thenUs` \ new_bs -> + returnUs (bagToList float_binds ++ -- Literals + new_b ++ + new_bs) - do_top_bind env bind@(CoRec pairs) + do_top_bind env bind@(Rec pairs) = coreBindToStg env bind - do_top_bind env bind@(CoNonRec var rhs) - = coreBindToStg env bind `thenSUs` \ (stg_binds, new_env, float_binds) -> - + do_top_bind env bind@(NonRec var rhs) + = coreBindToStg env bind `thenUs` \ (stg_binds, new_env, float_binds) -> +{- TESTING: + let + ppr_blah xs = ppInterleave ppComma (map pp_x xs) + pp_x (u,x) = ppBesides [pprUnique u, ppStr ": ", ppr PprDebug x] + in + pprTrace "do_top_bind:" (ppAbove (ppr PprDebug stg_binds) (ppr_blah (ufmToList new_env))) $ +-} case stg_binds of - [StgNonRec var (StgRhsClosure cc bi fvs u [] rhs_body)] -> + [StgNonRec var (StgRhsClosure cc bi fvs u [] rhs_body)] -> -- Mega-special case; there's still a binding there -- no fvs (of course), *no args*, "let" rhs - let + let (extra_float_binds, rhs_body') = seek_liftable [] rhs_body - in - returnSUs (extra_float_binds ++ + in + returnUs (extra_float_binds ++ [StgNonRec var (StgRhsClosure cc bi fvs u [] rhs_body')], new_env, float_binds) - other -> returnSUs (stg_binds, new_env, float_binds) + other -> returnUs (stg_binds, new_env, float_binds) -------------------- -- HACK: look for very simple, obviously-liftable bindings -- that can come up to the top level; those that couldn't -- 'cause they were big-lambda constrained in the Core world. - seek_liftable :: [PlainStgBinding] -- accumulator... - -> PlainStgExpr -- look for top-lev liftables - -> ([PlainStgBinding], PlainStgExpr) -- result + seek_liftable :: [StgBinding] -- accumulator... + -> StgExpr -- look for top-lev liftables + -> ([StgBinding], StgExpr) -- result seek_liftable acc expr@(StgLet inner_bind body) | is_liftable inner_bind @@ -160,12 +165,12 @@ topCoreBindsToStg us core_binds -------------------- is_liftable (StgNonRec binder (StgRhsClosure _ _ _ _ args body)) = not (null args) -- it's manifestly a function... - || isLeakFreeType [] (getIdUniType binder) + || isLeakFreeType [] (idType binder) || is_whnf body -- ToDo: use a decent manifestlyWHNF function for STG? where - is_whnf (StgConApp _ _ _) = True - is_whnf (StgApp (StgVarAtom v) _ _) = isBottomingId v + is_whnf (StgCon _ _ _) = True + is_whnf (StgApp (StgVarArg v) _ _) = isBottomingId v is_whnf other = False is_liftable (StgRec [(_, StgRhsClosure _ _ _ _ args body)]) @@ -182,45 +187,47 @@ topCoreBindsToStg us core_binds \begin{code} coreBindToStg :: StgEnv - -> PlainCoreBinding - -> SUniqSM ([PlainStgBinding], -- Empty or singleton + -> CoreBinding + -> UniqSM ([StgBinding], -- Empty or singleton StgEnv, -- New envt - Bag PlainStgBinding) -- Floats + Bag StgBinding) -- Floats -coreBindToStg env (CoNonRec binder rhs) - = coreRhsToStg env rhs `thenSUs` \ (stg_rhs, rhs_binds) -> +coreBindToStg env (NonRec binder rhs) + = coreRhsToStg env rhs `thenUs` \ (stg_rhs, rhs_binds) -> let -- Binds to return if RHS is trivial - triv_binds = if isExported binder then + triv_binds = if externallyVisibleId binder then + -- pprTrace "coreBindToStg:keeping:" (ppCat [ppr PprDebug binder, ppr PprDebug (externallyVisibleId binder)]) $ [StgNonRec binder stg_rhs] -- Retain it else + -- pprTrace "coreBindToStg:tossing:" (ppCat [ppr PprDebug binder, ppr PprDebug (externallyVisibleId binder)]) $ [] -- Discard it in case stg_rhs of - StgRhsClosure cc bi fvs upd [] (StgApp atom [] lvs) -> + StgRhsClosure cc bi fvs upd [] (StgApp atom [] lvs) -> -- Trivial RHS, so augment envt, and ditch the binding - returnSUs (triv_binds, new_env, rhs_binds) + returnUs (triv_binds, new_env, rhs_binds) where new_env = addOneToIdEnv env binder atom - - StgRhsCon cc con_id [] -> + + StgRhsCon cc con_id [] -> -- Trivial RHS, so augment envt, and ditch the binding - returnSUs (triv_binds, new_env, rhs_binds) + returnUs (triv_binds, new_env, rhs_binds) where - new_env = addOneToIdEnv env binder (StgVarAtom con_id) + new_env = addOneToIdEnv env binder (StgVarArg con_id) other -> -- Non-trivial RHS, so don't augment envt - returnSUs ([StgNonRec binder stg_rhs], env, rhs_binds) + returnUs ([StgNonRec binder stg_rhs], env, rhs_binds) -coreBindToStg env (CoRec pairs) +coreBindToStg env (Rec pairs) = -- NB: *** WE DO NOT CHECK FOR TRIV_BINDS in REC BIND **** -- (possibly ToDo) let (binders, rhss) = unzip pairs in - mapAndUnzipSUs (coreRhsToStg env) rhss `thenSUs` \ (stg_rhss, rhs_binds) -> - returnSUs ([StgRec (binders `zip` stg_rhss)], env, unionManyBags rhs_binds) + mapAndUnzipUs (coreRhsToStg env) rhss `thenUs` \ (stg_rhss, rhs_binds) -> + returnUs ([StgRec (binders `zip` stg_rhss)], env, unionManyBags rhs_binds) \end{code} @@ -231,28 +238,28 @@ coreBindToStg env (CoRec pairs) %************************************************************************ \begin{code} -coreRhsToStg :: StgEnv -> PlainCoreExpr -> SUniqSM (PlainStgRhs, Bag PlainStgBinding) +coreRhsToStg :: StgEnv -> CoreExpr -> UniqSM (StgRhs, Bag StgBinding) coreRhsToStg env core_rhs - = coreExprToStg env core_rhs `thenSUs` \ (stg_expr, stg_binds) -> + = coreExprToStg env core_rhs `thenUs` \ (stg_expr, stg_binds) -> let stg_rhs = case stg_expr of - StgLet (StgNonRec var1 rhs) (StgApp (StgVarAtom var2) [] _) + StgLet (StgNonRec var1 rhs) (StgApp (StgVarArg var2) [] _) | var1 == var2 -> rhs -- This curious stuff is to unravel what a lambda turns into -- We have to do it this way, rather than spot a lambda in the -- incoming rhs - StgConApp con args _ -> StgRhsCon noCostCentre con args + StgCon con args _ -> StgRhsCon noCostCentre con args other -> StgRhsClosure noCostCentre -- No cost centre (ToDo?) stgArgOcc -- safe - bOGUS_FVs - Updatable -- Be pessimistic - [] - stg_expr + bOGUS_FVs + Updatable -- Be pessimistic + [] + stg_expr in - returnSUs (stg_rhs, stg_binds) + returnUs (stg_rhs, stg_binds) \end{code} @@ -275,37 +282,46 @@ tARGET_MIN_INT, tARGET_MAX_INT :: Integer tARGET_MIN_INT = -536870912 tARGET_MAX_INT = 536870912 -litToStgAtom :: BasicLit -> SUniqSM (PlainStgAtom, Bag PlainStgBinding) +litToStgArg :: Literal -> UniqSM (StgArg, Bag StgBinding) -litToStgAtom (NoRepStr s) - = newStgVar stringTy `thenSUs` \ var -> +litToStgArg (NoRepStr s) + = newStgVar stringTy `thenUs` \ var -> let rhs = StgRhsClosure noCostCentre -- No cost centre (ToDo?) stgArgOcc -- safe bOGUS_FVs - Updatable -- OLD: ReEntrant (see note below) + Updatable -- WAS: ReEntrant (see note below) [] -- No arguments val -- We used not to update strings, so that they wouldn't clog up the heap, --- but instead be unpacked each time. But on some programs that costs a lot +-- but instead be unpacked each time. But on some programs that costs a lot -- [eg hpg], so now we update them. - val = StgApp (StgVarAtom unpackCStringId) - [StgLitAtom (MachStr s)] + val = if (any is_NUL (_UNPK_ s)) then -- must cater for NULs in literal string + StgApp (StgVarArg unpackCString2Id) + [StgLitArg (MachStr s), + StgLitArg (mkMachInt (toInteger (_LENGTH_ s)))] + bOGUS_LVs + else + StgApp (StgVarArg unpackCStringId) + [StgLitArg (MachStr s)] bOGUS_LVs in - returnSUs (StgVarAtom var, unitBag (StgNonRec var rhs)) + returnUs (StgVarArg var, unitBag (StgNonRec var rhs)) + where + is_NUL c = c == '\0' -litToStgAtom (NoRepInteger i) +litToStgArg (NoRepInteger i integer_ty) -- extremely convenient to look out for a few very common -- Integer literals! - | i == 0 = returnSUs (StgVarAtom integerZeroId, emptyBag) - | i == 1 = returnSUs (StgVarAtom integerPlusOneId, emptyBag) - | i == (-1) = returnSUs (StgVarAtom integerMinusOneId, emptyBag) + | i == 0 = returnUs (StgVarArg integerZeroId, emptyBag) + | i == 1 = returnUs (StgVarArg integerPlusOneId, emptyBag) + | i == 2 = returnUs (StgVarArg integerPlusTwoId, emptyBag) + | i == (-1) = returnUs (StgVarArg integerMinusOneId, emptyBag) | otherwise - = newStgVar integerTy `thenSUs` \ var -> + = newStgVar integer_ty `thenUs` \ var -> let rhs = StgRhsClosure noCostCentre -- No cost centre (ToDo?) stgArgOcc -- safe @@ -314,31 +330,46 @@ litToStgAtom (NoRepInteger i) [] -- No arguments val - val + val | i > tARGET_MIN_INT && i < tARGET_MAX_INT = -- Start from an Int - StgPrimApp Int2IntegerOp [StgLitAtom (mkMachInt i)] bOGUS_LVs + StgPrim Int2IntegerOp [StgLitArg (mkMachInt i)] bOGUS_LVs | otherwise = -- Start from a string - StgPrimApp Addr2IntegerOp [StgLitAtom (MachStr (_PK_ (show i)))] bOGUS_LVs + StgPrim Addr2IntegerOp [StgLitArg (MachStr (_PK_ (show i)))] bOGUS_LVs + in + returnUs (StgVarArg var, unitBag (StgNonRec var rhs)) + +litToStgArg (NoRepRational r rational_ty) + = --ASSERT(is_rational_ty) + --(if is_rational_ty then \x->x else pprTrace "litToStgArg:not rational?" (pprType PprDebug rational_ty)) $ + litToStgArg (NoRepInteger (numerator r) integer_ty) `thenUs` \ (num_atom, binds1) -> + litToStgArg (NoRepInteger (denominator r) integer_ty) `thenUs` \ (denom_atom, binds2) -> + newStgVar rational_ty `thenUs` \ var -> + let + rhs = StgRhsCon noCostCentre -- No cost centre (ToDo?) + ratio_data_con -- Constructor + [num_atom, denom_atom] in - returnSUs (StgVarAtom var, unitBag (StgNonRec var rhs)) - -litToStgAtom (NoRepRational r) - = litToStgAtom (NoRepInteger (numerator r)) `thenSUs` \ (num_atom, binds1) -> - litToStgAtom (NoRepInteger (denominator r)) `thenSUs` \ (denom_atom, binds2) -> - newStgVar rationalTy `thenSUs` \ var -> - let - rhs = StgRhsCon noCostCentre -- No cost centre (ToDo?) - ratioDataCon -- Constructor - [num_atom, denom_atom] - in - returnSUs (StgVarAtom var, binds1 `unionBags` - binds2 `unionBags` - unitBag (StgNonRec var rhs)) - -litToStgAtom other_lit = returnSUs (StgLitAtom other_lit, emptyBag) + returnUs (StgVarArg var, binds1 `unionBags` + binds2 `unionBags` + unitBag (StgNonRec var rhs)) + where + (is_rational_ty, ratio_data_con, integer_ty) + = case (maybeAppDataTyCon rational_ty) of + Just (tycon, [i_ty], [con]) + -> ASSERT(is_integer_ty i_ty) + (uniqueOf tycon == ratioTyConKey, con, i_ty) + + _ -> (False, panic "ratio_data_con", panic "integer_ty") + + is_integer_ty ty + = case (maybeAppDataTyCon ty) of + Just (tycon, [], _) -> uniqueOf tycon == integerTyConKey + _ -> False + +litToStgArg other_lit = returnUs (StgLitArg other_lit, emptyBag) \end{code} @@ -349,19 +380,29 @@ litToStgAtom other_lit = returnSUs (StgLitAtom other_lit, emptyBag) %************************************************************************ \begin{code} -coreAtomToStg :: StgEnv -> PlainCoreAtom -> SUniqSM (PlainStgAtom, Bag PlainStgBinding) +coreArgsToStg :: StgEnv -> [CoreArg] -> UniqSM ([Type], [StgArg], Bag StgBinding) -coreAtomToStg env (CoVarAtom var) = returnSUs (stgLookup env var, emptyBag) -coreAtomToStg env (CoLitAtom lit) = litToStgAtom lit +coreArgsToStg env [] = returnUs ([], [], emptyBag) +coreArgsToStg env (a:as) + = coreArgsToStg env as `thenUs` \ (tys, args, binds) -> + do_arg a tys args binds + where + do_arg a trest vrest binds + = case a of + TyArg t -> returnUs (t:trest, vrest, binds) + UsageArg u -> returnUs (trest, vrest, binds) + VarArg v -> returnUs (trest, stgLookup env v : vrest, binds) + LitArg i -> litToStgArg i `thenUs` \ (v, bs) -> + returnUs (trest, v:vrest, bs `unionBags` binds) \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 -> PlainStgAtom +stgLookup :: StgEnv -> Id -> StgArg stgLookup env var = case (lookupIdEnv env var) of - Nothing -> StgVarAtom var + Nothing -> StgVarArg var Just atom -> atom \end{code} @@ -372,42 +413,30 @@ stgLookup env var = case (lookupIdEnv env var) of %************************************************************************ \begin{code} -coreExprToStg :: StgEnv - -> PlainCoreExpr - -> SUniqSM (PlainStgExpr, -- Result - Bag PlainStgBinding) -- Float these to top level +coreExprToStg :: StgEnv + -> CoreExpr + -> UniqSM (StgExpr, -- Result + Bag StgBinding) -- Float these to top level \end{code} \begin{code} -coreExprToStg env (CoLit lit) - = litToStgAtom lit `thenSUs` \ (atom, binds) -> - returnSUs (StgApp atom [] bOGUS_LVs, binds) +coreExprToStg env (Lit lit) + = litToStgArg lit `thenUs` \ (atom, binds) -> + returnUs (StgApp atom [] bOGUS_LVs, binds) -coreExprToStg env (CoVar var) - = returnSUs (StgApp (stgLookup env var) [] bOGUS_LVs, emptyBag) +coreExprToStg env (Var var) + = returnUs (StgApp (stgLookup env var) [] bOGUS_LVs, emptyBag) -coreExprToStg env (CoCon con types args) - = mapAndUnzipSUs (coreAtomToStg env) args `thenSUs` \ (stg_atoms, stg_binds) -> - returnSUs (StgConApp spec_con stg_atoms bOGUS_LVs, unionManyBags stg_binds) - where - spec_con = mkSpecialisedCon con types - -coreExprToStg env (CoPrim op tys args) - = mapAndUnzipSUs (coreAtomToStg env) args `thenSUs` \ (stg_atoms, stg_binds) -> - returnSUs (StgPrimApp op stg_atoms bOGUS_LVs, unionManyBags stg_binds) -\end{code} - -%************************************************************************ -%* * -\subsubsection[coreToStg-type-stuff]{Type application and abstraction} -%* * -%************************************************************************ - -This type information dies in this Core-to-STG translation. +coreExprToStg env (Con con args) + = coreArgsToStg env args `thenUs` \ (types, stg_atoms, stg_binds) -> + let + spec_con = mkSpecialisedCon con types + in + returnUs (StgCon spec_con stg_atoms bOGUS_LVs, stg_binds) -\begin{code} -coreExprToStg env (CoTyLam tyvar expr) = coreExprToStg env expr -coreExprToStg env (CoTyApp expr ty) = coreExprToStg env expr +coreExprToStg env (Prim op args) + = coreArgsToStg env args `thenUs` \ (_, stg_atoms, stg_binds) -> + returnUs (StgPrim op stg_atoms bOGUS_LVs, stg_binds) \end{code} %************************************************************************ @@ -417,17 +446,25 @@ coreExprToStg env (CoTyApp expr ty) = coreExprToStg env expr %************************************************************************ \begin{code} -coreExprToStg env expr@(CoLam binders body) - = coreExprToStg env body `thenSUs` \ (stg_body, binds) -> - newStgVar (typeOfCoreExpr expr) `thenSUs` \ var -> - returnSUs (StgLet (StgNonRec var (StgRhsClosure noCostCentre - stgArgOcc - bOGUS_FVs - ReEntrant -- binders is non-empty - binders - stg_body)) - (StgApp (StgVarAtom var) [] bOGUS_LVs), - binds) +coreExprToStg env expr@(Lam _ _) + = let + (_,_, binders, body) = collectBinders expr + in + coreExprToStg env body `thenUs` \ stuff@(stg_body, binds) -> + + if null binders then -- it was all type/usage binders; tossed + returnUs stuff + else + newStgVar (coreExprType expr) `thenUs` \ var -> + returnUs + (StgLet (StgNonRec var (StgRhsClosure noCostCentre + stgArgOcc + bOGUS_FVs + ReEntrant -- binders is non-empty + binders + stg_body)) + (StgApp (StgVarArg var) [] bOGUS_LVs), + binds) \end{code} %************************************************************************ @@ -437,18 +474,25 @@ coreExprToStg env expr@(CoLam binders body) %************************************************************************ \begin{code} -coreExprToStg env expr@(CoApp _ _) - = -- Deal with the arguments - mapAndUnzipSUs (coreAtomToStg env) args `thenSUs` \ (stg_args, arg_binds) -> +coreExprToStg env expr@(App _ _) + = let + (fun,args) = collect_args expr [] + in + -- Deal with the arguments + coreArgsToStg env args `thenUs` \ (_, stg_args, arg_binds) -> -- Now deal with the function - case fun of - CoVar fun_id -> returnSUs (StgApp (stgLookup env fun_id) stg_args bOGUS_LVs, - unionManyBags arg_binds) + case (fun, args) of + (Var fun_id, _) -> -- A function Id, so do an StgApp; it's ok if + -- there are no arguments. + returnUs (StgApp (stgLookup env fun_id) stg_args bOGUS_LVs, arg_binds) + + (non_var_fun, []) -> -- No value args, so recurse into the function + coreExprToStg env non_var_fun other -> -- A non-variable applied to things; better let-bind it. - newStgVar (typeOfCoreExpr fun) `thenSUs` \ fun_id -> - coreExprToStg env fun `thenSUs` \ (stg_fun, fun_binds) -> + newStgVar (coreExprType fun) `thenUs` \ fun_id -> + coreExprToStg env fun `thenUs` \ (stg_fun, fun_binds) -> let fun_rhs = StgRhsClosure noCostCentre -- No cost centre (ToDo?) stgArgOcc @@ -457,17 +501,15 @@ coreExprToStg env expr@(CoApp _ _) [] stg_fun in - returnSUs (StgLet (StgNonRec fun_id fun_rhs) - (StgApp (StgVarAtom fun_id) stg_args bOGUS_LVs), - unionManyBags arg_binds `unionBags` - fun_binds) + returnUs (StgLet (StgNonRec fun_id fun_rhs) + (StgApp (StgVarArg fun_id) stg_args bOGUS_LVs), + arg_binds `unionBags` fun_binds) where - (fun,args) = collect_args expr [] - - -- Collect arguments, discarding type applications - collect_args (CoApp fun arg) args = collect_args fun (arg:args) - collect_args (CoTyApp e t) args = collect_args e args - collect_args fun args = (fun, args) + -- Collect arguments, discarding type/usage applications + collect_args (App e (TyArg _)) args = collect_args e args + collect_args (App e (UsageArg _)) args = collect_args e args + collect_args (App fun arg) args = collect_args fun (arg:args) + collect_args fun args = (fun, args) \end{code} %************************************************************************ @@ -496,12 +538,12 @@ to \begin{code} -coreExprToStg env (CoCase discrim@(CoPrim op tys args) alts) - | funnyParallelOp op = - getSUnique `thenSUs` \ uniq -> - coreExprToStg env discrim `thenSUs` \ (stg_discrim, discrim_binds) -> - alts_to_stg alts `thenSUs` \ (stg_alts, alts_binds) -> - returnSUs ( +coreExprToStg env (Case discrim@(Prim op _) alts) + | funnyParallelOp op + = getUnique `thenUs` \ uniq -> + coreExprToStg env discrim `thenUs` \ (stg_discrim, discrim_binds) -> + alts_to_stg alts `thenUs` \ (stg_alts, alts_binds) -> + returnUs ( StgCase stg_discrim bOGUS_LVs bOGUS_LVs @@ -515,22 +557,22 @@ coreExprToStg env (CoCase discrim@(CoPrim op tys args) alts) funnyParallelOp ForkOp = True funnyParallelOp _ = False - discrim_ty = typeOfCoreExpr discrim + discrim_ty = coreExprType discrim - alts_to_stg (CoPrimAlts _ (CoBindDefault binder rhs)) - = coreExprToStg env rhs `thenSUs` \ (stg_rhs, rhs_binds) -> - let - stg_deflt = StgBindDefault binder False stg_rhs - in - returnSUs (StgPrimAlts discrim_ty [] stg_deflt, rhs_binds) + alts_to_stg (PrimAlts _ (BindDefault binder rhs)) + = coreExprToStg env rhs `thenUs` \ (stg_rhs, rhs_binds) -> + let + stg_deflt = StgBindDefault binder False stg_rhs + in + returnUs (StgPrimAlts discrim_ty [] stg_deflt, rhs_binds) -- OK, back to real life... -coreExprToStg env (CoCase discrim alts) - = coreExprToStg env discrim `thenSUs` \ (stg_discrim, discrim_binds) -> - alts_to_stg discrim alts `thenSUs` \ (stg_alts, alts_binds) -> - getSUnique `thenSUs` \ uniq -> - returnSUs ( +coreExprToStg env (Case discrim alts) + = coreExprToStg env discrim `thenUs` \ (stg_discrim, discrim_binds) -> + alts_to_stg discrim alts `thenUs` \ (stg_alts, alts_binds) -> + getUnique `thenUs` \ uniq -> + returnUs ( StgCase stg_discrim bOGUS_LVs bOGUS_LVs @@ -539,63 +581,42 @@ coreExprToStg env (CoCase discrim alts) discrim_binds `unionBags` alts_binds ) where - discrim_ty = typeOfCoreExpr discrim - (_, discrim_ty_args, _) = getUniDataTyCon discrim_ty + discrim_ty = coreExprType discrim + (_, discrim_ty_args, _) = getAppDataTyConExpandingDicts discrim_ty - alts_to_stg discrim (CoAlgAlts alts deflt) - = default_to_stg discrim deflt `thenSUs` \ (stg_deflt, deflt_binds) -> - mapAndUnzipSUs boxed_alt_to_stg alts `thenSUs` \ (stg_alts, alts_binds) -> - returnSUs (StgAlgAlts discrim_ty stg_alts stg_deflt, + alts_to_stg discrim (AlgAlts alts deflt) + = default_to_stg discrim deflt `thenUs` \ (stg_deflt, deflt_binds) -> + mapAndUnzipUs boxed_alt_to_stg alts `thenUs` \ (stg_alts, alts_binds) -> + returnUs (StgAlgAlts discrim_ty stg_alts stg_deflt, deflt_binds `unionBags` unionManyBags alts_binds) where boxed_alt_to_stg (con, bs, rhs) - = coreExprToStg env rhs `thenSUs` \ (stg_rhs, rhs_binds) -> - returnSUs ((spec_con, bs, [ True | b <- bs ]{-bogus use mask-}, stg_rhs), + = coreExprToStg env rhs `thenUs` \ (stg_rhs, rhs_binds) -> + returnUs ((spec_con, bs, [ True | b <- bs ]{-bogus use mask-}, stg_rhs), rhs_binds) where spec_con = mkSpecialisedCon con discrim_ty_args - alts_to_stg discrim (CoPrimAlts alts deflt) - = default_to_stg discrim deflt `thenSUs` \ (stg_deflt,deflt_binds) -> - mapAndUnzipSUs unboxed_alt_to_stg alts `thenSUs` \ (stg_alts, alts_binds) -> - returnSUs (StgPrimAlts discrim_ty stg_alts stg_deflt, + alts_to_stg discrim (PrimAlts alts deflt) + = default_to_stg discrim deflt `thenUs` \ (stg_deflt,deflt_binds) -> + mapAndUnzipUs unboxed_alt_to_stg alts `thenUs` \ (stg_alts, alts_binds) -> + returnUs (StgPrimAlts discrim_ty stg_alts stg_deflt, deflt_binds `unionBags` unionManyBags alts_binds) where unboxed_alt_to_stg (lit, rhs) - = coreExprToStg env rhs `thenSUs` \ (stg_rhs, rhs_binds) -> - returnSUs ((lit, stg_rhs), rhs_binds) - -#ifdef DPH - alts_to_stg (CoParAlgAlts tycon ctxt params alts deflt) - = default_to_stg deflt `thenSUs` \ stg_deflt -> - mapSUs boxed_alt_to_stg alts `thenSUs` \ stg_alts -> - returnSUs (StgParAlgAlts discrim_ty ctxt params stg_alts stg_deflt) - where - boxed_alt_to_stg (con, rhs) - = coreExprToStg env rhs `thenSUs` \ stg_rhs -> - returnSUs (con, stg_rhs) - - alts_to_stg (CoParPrimAlts tycon ctxt alts deflt) - = default_to_stg deflt `thenSUs` \ stg_deflt -> - mapSUs unboxed_alt_to_stg alts `thenSUs` \ stg_alts -> - returnSUs (StgParPrimAlts discrim_ty ctxt stg_alts stg_deflt) - where - unboxed_alt_to_stg (lit, rhs) - = coreExprToStg env rhs `thenSUs` \ stg_rhs -> - returnSUs (lit, stg_rhs) -#endif {- Data Parallel Haskell -} + = coreExprToStg env rhs `thenUs` \ (stg_rhs, rhs_binds) -> + returnUs ((lit, stg_rhs), rhs_binds) - default_to_stg discrim CoNoDefault - = returnSUs (StgNoDefault, emptyBag) + default_to_stg discrim NoDefault + = returnUs (StgNoDefault, emptyBag) - default_to_stg discrim (CoBindDefault binder rhs) - = coreExprToStg new_env rhs `thenSUs` \ (stg_rhs, rhs_binds) -> - returnSUs (StgBindDefault binder True{-used? no it is lying-} stg_rhs, + default_to_stg discrim (BindDefault binder rhs) + = coreExprToStg new_env rhs `thenUs` \ (stg_rhs, rhs_binds) -> + returnUs (StgBindDefault binder True{-used? no it is lying-} stg_rhs, rhs_binds) where - - - -- We convert case x of {...; x' -> ...x'...} + -- + -- We convert case x of {...; x' -> ...x'...} -- to -- case x of {...; _ -> ...x... } -- @@ -604,7 +625,7 @@ coreExprToStg env (CoCase discrim alts) -- default binder to the scrutinee. -- new_env = case discrim of - CoVar v -> addOneToIdEnv env binder (StgVarAtom v) + Var v -> addOneToIdEnv env binder (stgLookup env v) other -> env \end{code} @@ -615,10 +636,10 @@ coreExprToStg env (CoCase discrim alts) %************************************************************************ \begin{code} -coreExprToStg env (CoLet bind body) - = coreBindToStg env bind `thenSUs` \ (stg_binds, new_env, float_binds1) -> - coreExprToStg new_env body `thenSUs` \ (stg_body, float_binds2) -> - returnSUs (mkStgLets stg_binds stg_body, float_binds1 `unionBags` float_binds2) +coreExprToStg env (Let bind body) + = coreBindToStg env bind `thenUs` \ (stg_binds, new_env, float_binds1) -> + coreExprToStg new_env body `thenUs` \ (stg_body, float_binds2) -> + returnUs (mkStgLets stg_binds stg_body, float_binds1 `unionBags` float_binds2) \end{code} @@ -630,48 +651,15 @@ coreExprToStg env (CoLet bind body) Covert core @scc@ expression directly to STG @scc@ expression. \begin{code} -coreExprToStg env (CoSCC cc expr) - = coreExprToStg env expr `thenSUs` \ (stg_expr, binds) -> - returnSUs (StgSCC (typeOfCoreExpr expr) cc stg_expr, binds) +coreExprToStg env (SCC cc expr) + = coreExprToStg env expr `thenUs` \ (stg_expr, binds) -> + returnUs (StgSCC (coreExprType expr) cc stg_expr, binds) \end{code} -%************************************************************************ -%* * -\subsubsection[coreToStg-dataParallel]{Data Parallel expressions} -%* * -%************************************************************************ \begin{code} -#ifdef DPH -coreExprToStg env (_, AnnCoParCon con ctxt types args) - = mapAndUnzipSUs (arg2stg env) args `thenSUs` \ (stg_atoms, stg_binds) -> - returnSUs (mkStgLets (catMaybes stg_binds) - (StgParConApp con ctxt stg_atoms bOGUS_LVs)) - -coreExprToStg env (_,AnnCoParComm ctxt expr comm) - = coreExprToStg env expr `thenSUs` \ stg_expr -> - annComm_to_stg comm `thenSUs` \ (stg_comm,stg_binds) -> - returnSUs (mkStgLets (catMaybes stg_binds) - (StgParComm ctxt stg_expr stg_comm)) - )) - where - annComm_to_stg (AnnCoParSend args) - = mapAndUnzipSUs (arg2stg env) args `thenSUs` \ (stg_atoms, stg_binds) -> - returnSUs (StgParSend stg_atoms,stg_binds) - - annComm_to_stg (AnnCoParFetch args) - = mapAndUnzipSUs (arg2stg env) args `thenSUs` \ (stg_atoms, stg_binds) -> - returnSUs (StgParFetch stg_atoms,stg_binds) - - annComm_to_stg (AnnCoToPodized) - = returnSUs (StgToPodized,[]) - annComm_to_stg (AnnCoFromPodized) - = returnSUs (StgFromPodized,[]) -#endif {- Data Parallel Haskell -} +coreExprToStg env (Coerce c ty expr) = coreExprToStg env expr \end{code} -\begin{code} -coreExprToStg env other = panic "coreExprToStg: it really failed here" -\end{code} %************************************************************************ %* * @@ -683,16 +671,16 @@ Utilities. Invent a fresh @Id@: \begin{code} -newStgVar :: UniType -> SUniqSM Id +newStgVar :: Type -> UniqSM Id newStgVar ty - = getSUnique `thenSUs` \ uniq -> - returnSUs (mkSysLocal SLIT("stg") uniq ty mkUnknownSrcLoc) + = getUnique `thenUs` \ uniq -> + returnUs (mkSysLocal SLIT("stg") uniq ty mkUnknownSrcLoc) \end{code} \begin{code} -mkStgLets :: [PlainStgBinding] - -> PlainStgExpr -- body of let - -> PlainStgExpr +mkStgLets :: [StgBinding] + -> StgExpr -- body of let + -> StgExpr mkStgLets binds body = foldr StgLet body binds \end{code}