X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FstgSyn%2FCoreToStg.lhs;h=114131aeac3cfc186b3cbe23719a4631d7bade6a;hb=f7ecf7234c224489be8a5e63fced903b655d92ee;hp=233cca7020478a75a2becc1e9148de6281db2536;hpb=f01a8e8c9c53bfb5ab3393ed3457ebf25390efa1;p=ghc-hetmet.git diff --git a/ghc/compiler/stgSyn/CoreToStg.lhs b/ghc/compiler/stgSyn/CoreToStg.lhs index 233cca7..114131a 100644 --- a/ghc/compiler/stgSyn/CoreToStg.lhs +++ b/ghc/compiler/stgSyn/CoreToStg.lhs @@ -9,13 +9,13 @@ Convert a @CoreSyntax@ program to a @StgSyntax@ program. - \begin{code} #include "HsVersions.h" module CoreToStg ( topCoreBindsToStg ) where -import Ubiq{-uitous-} +IMP_Ubiq(){-uitous-} +IMPORT_1_3(Ratio(numerator,denominator)) import CoreSyn -- input import StgSyn -- output @@ -24,22 +24,29 @@ import Bag ( emptyBag, unitBag, unionBags, unionManyBags, bagToList ) import CoreUtils ( coreExprType ) import CostCentre ( noCostCentre ) import Id ( mkSysLocal, idType, isBottomingId, + externallyVisibleId, nullIdEnv, addOneToIdEnv, lookupIdEnv, - IdEnv(..), GenId{-instance NamedThing-} + SYN_IE(IdEnv), GenId{-instance NamedThing-} ) import Literal ( mkMachInt, Literal(..) ) -import Name ( isExported ) -import PrelInfo ( unpackCStringId, unpackCString2Id, stringTy, - integerTy, rationalTy, ratioDataCon, +import PrelVals ( unpackCStringId, unpackCString2Id, integerZeroId, integerPlusOneId, integerPlusTwoId, integerMinusOneId ) import PrimOp ( PrimOp(..) ) import SpecUtils ( mkSpecialisedCon ) import SrcLoc ( mkUnknownSrcLoc ) -import Type ( getAppDataTyCon ) +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 ) +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} @@ -190,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 @@ -303,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) @@ -312,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 @@ -332,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} @@ -426,17 +450,21 @@ coreExprToStg env expr@(Lam _ _) = let (_,_, binders, body) = collectBinders expr in - 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) + 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} %************************************************************************ @@ -448,14 +476,19 @@ coreExprToStg env expr@(Lam _ _) \begin{code} coreExprToStg env expr@(App _ _) = let - (fun, _, _, args) = collectArgs expr + (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, 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 -> @@ -471,6 +504,12 @@ coreExprToStg env expr@(App _ _) returnUs (StgLet (StgNonRec fun_id fun_rhs) (StgApp (StgVarArg fun_id) stg_args bOGUS_LVs), arg_binds `unionBags` fun_binds) + where + -- 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} %************************************************************************ @@ -543,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) -> @@ -618,9 +657,7 @@ coreExprToStg env (SCC cc expr) \end{code} \begin{code} -coreExprToStg env (Coerce c ty expr) - = coreExprToStg env expr -- `thenUs` \ (stg_expr, binds) -> --- returnUs (StgSCC (coreExprType expr) cc stg_expr, binds) +coreExprToStg env (Coerce c ty expr) = coreExprToStg env expr \end{code}