X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FstgSyn%2FCoreToStg.lhs;h=114131aeac3cfc186b3cbe23719a4631d7bade6a;hb=f7ecf7234c224489be8a5e63fced903b655d92ee;hp=5afb086b0704fdba5aa118d13145d27a2f68206e;hpb=6c381e873e222417d9a67aeec77b9555eca7b7a8;p=ghc-hetmet.git diff --git a/ghc/compiler/stgSyn/CoreToStg.lhs b/ghc/compiler/stgSyn/CoreToStg.lhs index 5afb086..114131a 100644 --- a/ghc/compiler/stgSyn/CoreToStg.lhs +++ b/ghc/compiler/stgSyn/CoreToStg.lhs @@ -9,43 +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... - ) where +IMP_Ubiq(){-uitous-} +IMPORT_1_3(Ratio(numerator,denominator)) -import AnnCoreSyn -- intermediate form on which all work is done +import CoreSyn -- input import StgSyn -- output -import UniqSupply -import PrelInfo ( unpackCStringId, unpackCString2Id, stringTy, - integerTy, rationalTy, ratioDataCon, - PrimOp(..), -- For Int2IntegerOp etc +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 - IF_ATTACK_PRAGMAS(COMMA mkListTy COMMA charTy) - IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp) - IF_ATTACK_PRAGMAS(COMMA pprPrimOp) - ) - -import Type ( isPrimType, isLeakFreeType, getAppDataTyCon ) -import Bag -- Bag operations -import Literal ( mkMachInt, Literal(..) ) -- ToDo: its use is ugly... -import CostCentre ( noCostCentre, CostCentre ) -import Id ( mkSysLocal, idType, isBottomingId - IF_ATTACK_PRAGMAS(COMMA bottomIsGuaranteed) ) -import Maybes ( Maybe(..), catMaybes ) -import Outputable ( isExported ) -import Pretty -- debugging only! +import PrimOp ( PrimOp(..) ) import SpecUtils ( mkSpecialisedCon ) -import SrcLoc ( SrcLoc, mkUnknownSrcLoc ) -import Util +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} @@ -194,9 +197,11 @@ coreBindToStg env (NonRec binder rhs) 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 @@ -307,7 +312,7 @@ litToStgArg (NoRepStr s) where is_NUL c = c == '\0' -litToStgArg (NoRepInteger i) +litToStgArg (NoRepInteger i integer_ty) -- extremely convenient to look out for a few very common -- Integer literals! | i == 0 = returnUs (StgVarArg integerZeroId, emptyBag) @@ -316,7 +321,7 @@ litToStgArg (NoRepInteger i) | i == (-1) = returnUs (StgVarArg integerMinusOneId, emptyBag) | otherwise - = newStgVar integerTy `thenUs` \ var -> + = newStgVar integer_ty `thenUs` \ var -> let rhs = StgRhsClosure noCostCentre -- No cost centre (ToDo?) stgArgOcc -- safe @@ -336,18 +341,33 @@ litToStgArg (NoRepInteger i) in returnUs (StgVarArg var, unitBag (StgNonRec var rhs)) -litToStgArg (NoRepRational r) - = litToStgArg (NoRepInteger (numerator r)) `thenUs` \ (num_atom, binds1) -> - litToStgArg (NoRepInteger (denominator r)) `thenUs` \ (denom_atom, binds2) -> - newStgVar rationalTy `thenUs` \ var -> - let - rhs = StgRhsCon noCostCentre -- No cost centre (ToDo?) - ratioDataCon -- Constructor - [num_atom, denom_atom] - in - returnUs (StgVarArg var, binds1 `unionBags` - binds2 `unionBags` - 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 + 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} @@ -360,10 +380,20 @@ litToStgArg other_lit = returnUs (StgLitArg other_lit, emptyBag) %************************************************************************ \begin{code} -coreAtomToStg :: StgEnv -> CoreArg -> UniqSM (StgArg, Bag StgBinding) +coreArgsToStg :: StgEnv -> [CoreArg] -> UniqSM ([Type], [StgArg], Bag StgBinding) -coreAtomToStg env (VarArg var) = returnUs (stgLookup env var, emptyBag) -coreAtomToStg env (LitArg lit) = litToStgArg 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 @@ -397,28 +427,16 @@ coreExprToStg env (Lit lit) coreExprToStg env (Var var) = returnUs (StgApp (stgLookup env var) [] bOGUS_LVs, emptyBag) -coreExprToStg env (Con con types args) - = mapAndUnzipUs (coreAtomToStg env) args `thenUs` \ (stg_atoms, stg_binds) -> - returnUs (StgCon spec_con stg_atoms bOGUS_LVs, unionManyBags stg_binds) - where - spec_con = mkSpecialisedCon con types - -coreExprToStg env (Prim op tys args) - = mapAndUnzipUs (coreAtomToStg env) args `thenUs` \ (stg_atoms, stg_binds) -> - returnUs (StgPrim 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} %************************************************************************ @@ -429,25 +447,24 @@ coreExprToStg env (CoTyApp expr ty) = coreExprToStg env expr \begin{code} coreExprToStg env expr@(Lam _ _) - = coreExprToStg env body `thenUs` \ (stg_body, binds) -> - 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) - where - (binders,body) = collect expr - - -- Collect lambda-bindings, discarding type abstractions and applications - collect (Lam x e) = (x:binders, body) where (binders,body) = collect e - collect (CoTyLam _ e) = collect e - collect (CoTyApp e _) = collect e - collect body = ([], body) + = 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} %************************************************************************ @@ -458,13 +475,20 @@ coreExprToStg env expr@(Lam _ _) \begin{code} coreExprToStg env expr@(App _ _) - = -- Deal with the arguments - mapAndUnzipUs (coreAtomToStg env) args `thenUs` \ (stg_args, arg_binds) -> + = 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 - Var fun_id -> returnUs (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 (coreExprType fun) `thenUs` \ fun_id -> @@ -479,16 +503,13 @@ coreExprToStg env expr@(App _ _) in returnUs (StgLet (StgNonRec fun_id fun_rhs) (StgApp (StgVarArg fun_id) stg_args bOGUS_LVs), - unionManyBags arg_binds `unionBags` - fun_binds) + arg_binds `unionBags` fun_binds) where - (fun,args) = collect_args expr [] - - -- Collect arguments, discarding type abstractions and applications - collect_args (App fun arg) args = collect_args fun (arg:args) - collect_args (CoTyLam _ e) args = collect_args e args - collect_args (CoTyApp e _) 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} %************************************************************************ @@ -517,9 +538,9 @@ to \begin{code} -coreExprToStg env (Case discrim@(Prim op tys args) alts) - | funnyParallelOp op = - getUnique `thenUs` \ uniq -> +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 ( @@ -561,7 +582,7 @@ coreExprToStg env (Case discrim alts) ) where discrim_ty = coreExprType discrim - (_, discrim_ty_args, _) = getAppDataTyCon discrim_ty + (_, discrim_ty_args, _) = getAppDataTyConExpandingDicts discrim_ty alts_to_stg discrim (AlgAlts alts deflt) = default_to_stg discrim deflt `thenUs` \ (stg_deflt, deflt_binds) -> @@ -635,6 +656,10 @@ coreExprToStg env (SCC cc expr) returnUs (StgSCC (coreExprType expr) cc stg_expr, binds) \end{code} +\begin{code} +coreExprToStg env (Coerce c ty expr) = coreExprToStg env expr +\end{code} + %************************************************************************ %* *