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}
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
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)
| 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
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}
%************************************************************************
\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
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}
%************************************************************************
\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}
%************************************************************************
\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 ->
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}
%************************************************************************
\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 (
)
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) ->
returnUs (StgSCC (coreExprType expr) cc stg_expr, binds)
\end{code}
+\begin{code}
+coreExprToStg env (Coerce c ty expr) = coreExprToStg env expr
+\end{code}
+
%************************************************************************
%* *
projects / ghc-hetmet.git / blobdiff