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 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 ( getAppDataTyConExpandingDicts )
+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}
= 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}
%************************************************************************
\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}
projects / ghc-hetmet.git / blobdiff