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
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 PrelVals ( unpackCStringId, unpackCString2Id,
integerZeroId, integerPlusOneId,
integerPlusTwoId, integerMinusOneId
import PrimOp ( PrimOp(..) )
import SpecUtils ( mkSpecialisedCon )
import SrcLoc ( mkUnknownSrcLoc )
-import Type ( getAppDataTyConExpandingDicts )
-import TysWiredIn ( stringTy, integerTy, rationalTy, ratioDataCon )
+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}
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}
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 ->
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}
%************************************************************************
\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}