%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
%
%************************************************************************
%* *
#include "HsVersions.h"
module CoreToStg (
- topCoreBindsToStg,
+ topCoreBindsToStg
-- and to make the interface self-sufficient...
- SplitUniqSupply, Id, CoreExpr, CoreBinding, StgBinding,
- StgRhs, StgBinderInfo
) where
-import PlainCore -- input
import AnnCoreSyn -- intermediate form on which all work is done
import StgSyn -- output
-import SplitUniq
-import Unique -- the UniqueSupply monadery used herein
+import UniqSupply
-import AbsPrel ( unpackCStringId, unpackCString2Id, stringTy,
+import PrelInfo ( unpackCStringId, unpackCString2Id, stringTy,
integerTy, rationalTy, ratioDataCon,
PrimOp(..), -- For Int2IntegerOp etc
integerZeroId, integerPlusOneId,
IF_ATTACK_PRAGMAS(COMMA pprPrimOp)
)
-import AbsUniType ( isPrimType, isLeakFreeType, getUniDataTyCon )
+import Type ( isPrimType, isLeakFreeType, getAppDataTyCon )
import Bag -- Bag operations
-import BasicLit ( mkMachInt, BasicLit(..), PrimKind ) -- ToDo: its use is ugly...
+import Literal ( mkMachInt, Literal(..) ) -- ToDo: its use is ugly...
import CostCentre ( noCostCentre, CostCentre )
-import Id ( mkSysLocal, getIdUniType, isBottomingId
+import Id ( mkSysLocal, idType, isBottomingId
IF_ATTACK_PRAGMAS(COMMA bottomIsGuaranteed)
)
-import IdEnv
import Maybes ( Maybe(..), catMaybes )
import Outputable ( isExported )
import Pretty -- debugging only!
-import SpecTyFuns ( mkSpecialisedCon )
+import SpecUtils ( mkSpecialisedCon )
import SrcLoc ( SrcLoc, mkUnknownSrcLoc )
import Util
\end{code}
* We do *not* pin on the correct free/live var info; that's done later.
Instead we use bOGUS_LVS and _FVS as a placeholder.
-* We convert case x of {...; x' -> ...x'...}
+* We convert case x of {...; x' -> ...x'...}
to
case x of {...; _ -> ...x... }
with \tr{y}.
\begin{code}
-type StgEnv = IdEnv PlainStgAtom
+type StgEnv = IdEnv StgArg
\end{code}
No free/live variable information is pinned on in this pass; it's added
we use @bOGUS_LVs@ and @bOGUS_FVs@ as placeholders.
\begin{code}
-bOGUS_LVs :: PlainStgLiveVars
+bOGUS_LVs :: StgLiveVars
bOGUS_LVs = panic "bOGUS_LVs" -- emptyUniqSet (used when pprTracing)
bOGUS_FVs :: [Id]
\end{code}
\begin{code}
-topCoreBindsToStg :: SplitUniqSupply -- name supply
- -> [PlainCoreBinding] -- input
- -> [PlainStgBinding] -- output
+topCoreBindsToStg :: UniqSupply -- name supply
+ -> [CoreBinding] -- input
+ -> [StgBinding] -- output
topCoreBindsToStg us core_binds
- = case (initSUs us (binds_to_stg nullIdEnv core_binds)) of
+ = case (initUs us (binds_to_stg nullIdEnv core_binds)) of
(_, stuff) -> stuff
where
- binds_to_stg :: StgEnv -> [PlainCoreBinding] -> SUniqSM [PlainStgBinding]
+ binds_to_stg :: StgEnv -> [CoreBinding] -> UniqSM [StgBinding]
- binds_to_stg env [] = returnSUs []
+ binds_to_stg env [] = returnUs []
binds_to_stg env (b:bs)
- = do_top_bind env b `thenSUs` \ (new_b, new_env, float_binds) ->
- binds_to_stg new_env bs `thenSUs` \ new_bs ->
- returnSUs (bagToList float_binds ++ -- Literals
- new_b ++
- new_bs)
+ = do_top_bind env b `thenUs` \ (new_b, new_env, float_binds) ->
+ binds_to_stg new_env bs `thenUs` \ new_bs ->
+ returnUs (bagToList float_binds ++ -- Literals
+ new_b ++
+ new_bs)
- do_top_bind env bind@(CoRec pairs)
+ do_top_bind env bind@(Rec pairs)
= coreBindToStg env bind
- do_top_bind env bind@(CoNonRec var rhs)
- = coreBindToStg env bind `thenSUs` \ (stg_binds, new_env, float_binds) ->
+ do_top_bind env bind@(NonRec var rhs)
+ = coreBindToStg env bind `thenUs` \ (stg_binds, new_env, float_binds) ->
{- TESTING:
let
ppr_blah xs = ppInterleave ppComma (map pp_x xs)
pprTrace "do_top_bind:" (ppAbove (ppr PprDebug stg_binds) (ppr_blah (ufmToList new_env))) $
-}
case stg_binds of
- [StgNonRec var (StgRhsClosure cc bi fvs u [] rhs_body)] ->
+ [StgNonRec var (StgRhsClosure cc bi fvs u [] rhs_body)] ->
-- Mega-special case; there's still a binding there
-- no fvs (of course), *no args*, "let" rhs
- let
+ let
(extra_float_binds, rhs_body') = seek_liftable [] rhs_body
- in
- returnSUs (extra_float_binds ++
+ in
+ returnUs (extra_float_binds ++
[StgNonRec var (StgRhsClosure cc bi fvs u [] rhs_body')],
new_env,
float_binds)
- other -> returnSUs (stg_binds, new_env, float_binds)
+ other -> returnUs (stg_binds, new_env, float_binds)
--------------------
-- HACK: look for very simple, obviously-liftable bindings
-- that can come up to the top level; those that couldn't
-- 'cause they were big-lambda constrained in the Core world.
- seek_liftable :: [PlainStgBinding] -- accumulator...
- -> PlainStgExpr -- look for top-lev liftables
- -> ([PlainStgBinding], PlainStgExpr) -- result
+ seek_liftable :: [StgBinding] -- accumulator...
+ -> StgExpr -- look for top-lev liftables
+ -> ([StgBinding], StgExpr) -- result
seek_liftable acc expr@(StgLet inner_bind body)
| is_liftable inner_bind
--------------------
is_liftable (StgNonRec binder (StgRhsClosure _ _ _ _ args body))
= not (null args) -- it's manifestly a function...
- || isLeakFreeType [] (getIdUniType binder)
+ || isLeakFreeType [] (idType binder)
|| is_whnf body
-- ToDo: use a decent manifestlyWHNF function for STG?
where
- is_whnf (StgConApp _ _ _) = True
- is_whnf (StgApp (StgVarAtom v) _ _) = isBottomingId v
+ is_whnf (StgCon _ _ _) = True
+ is_whnf (StgApp (StgVarArg v) _ _) = isBottomingId v
is_whnf other = False
is_liftable (StgRec [(_, StgRhsClosure _ _ _ _ args body)])
\begin{code}
coreBindToStg :: StgEnv
- -> PlainCoreBinding
- -> SUniqSM ([PlainStgBinding], -- Empty or singleton
+ -> CoreBinding
+ -> UniqSM ([StgBinding], -- Empty or singleton
StgEnv, -- New envt
- Bag PlainStgBinding) -- Floats
+ Bag StgBinding) -- Floats
-coreBindToStg env (CoNonRec binder rhs)
- = coreRhsToStg env rhs `thenSUs` \ (stg_rhs, rhs_binds) ->
+coreBindToStg env (NonRec binder rhs)
+ = coreRhsToStg env rhs `thenUs` \ (stg_rhs, rhs_binds) ->
let
-- Binds to return if RHS is trivial
[] -- Discard it
in
case stg_rhs of
- StgRhsClosure cc bi fvs upd [] (StgApp atom [] lvs) ->
+ StgRhsClosure cc bi fvs upd [] (StgApp atom [] lvs) ->
-- Trivial RHS, so augment envt, and ditch the binding
- returnSUs (triv_binds, new_env, rhs_binds)
+ returnUs (triv_binds, new_env, rhs_binds)
where
new_env = addOneToIdEnv env binder atom
-
- StgRhsCon cc con_id [] ->
+
+ StgRhsCon cc con_id [] ->
-- Trivial RHS, so augment envt, and ditch the binding
- returnSUs (triv_binds, new_env, rhs_binds)
+ returnUs (triv_binds, new_env, rhs_binds)
where
- new_env = addOneToIdEnv env binder (StgVarAtom con_id)
+ new_env = addOneToIdEnv env binder (StgVarArg con_id)
other -> -- Non-trivial RHS, so don't augment envt
- returnSUs ([StgNonRec binder stg_rhs], env, rhs_binds)
+ returnUs ([StgNonRec binder stg_rhs], env, rhs_binds)
-coreBindToStg env (CoRec pairs)
+coreBindToStg env (Rec pairs)
= -- NB: *** WE DO NOT CHECK FOR TRIV_BINDS in REC BIND ****
-- (possibly ToDo)
let
(binders, rhss) = unzip pairs
in
- mapAndUnzipSUs (coreRhsToStg env) rhss `thenSUs` \ (stg_rhss, rhs_binds) ->
- returnSUs ([StgRec (binders `zip` stg_rhss)], env, unionManyBags rhs_binds)
+ mapAndUnzipUs (coreRhsToStg env) rhss `thenUs` \ (stg_rhss, rhs_binds) ->
+ returnUs ([StgRec (binders `zip` stg_rhss)], env, unionManyBags rhs_binds)
\end{code}
%************************************************************************
\begin{code}
-coreRhsToStg :: StgEnv -> PlainCoreExpr -> SUniqSM (PlainStgRhs, Bag PlainStgBinding)
+coreRhsToStg :: StgEnv -> CoreExpr -> UniqSM (StgRhs, Bag StgBinding)
coreRhsToStg env core_rhs
- = coreExprToStg env core_rhs `thenSUs` \ (stg_expr, stg_binds) ->
+ = coreExprToStg env core_rhs `thenUs` \ (stg_expr, stg_binds) ->
let stg_rhs = case stg_expr of
- StgLet (StgNonRec var1 rhs) (StgApp (StgVarAtom var2) [] _)
+ StgLet (StgNonRec var1 rhs) (StgApp (StgVarArg var2) [] _)
| var1 == var2 -> rhs
-- This curious stuff is to unravel what a lambda turns into
-- We have to do it this way, rather than spot a lambda in the
-- incoming rhs
- StgConApp con args _ -> StgRhsCon noCostCentre con args
+ StgCon con args _ -> StgRhsCon noCostCentre con args
other -> StgRhsClosure noCostCentre -- No cost centre (ToDo?)
stgArgOcc -- safe
- bOGUS_FVs
- Updatable -- Be pessimistic
- []
- stg_expr
+ bOGUS_FVs
+ Updatable -- Be pessimistic
+ []
+ stg_expr
in
- returnSUs (stg_rhs, stg_binds)
+ returnUs (stg_rhs, stg_binds)
\end{code}
tARGET_MIN_INT = -536870912
tARGET_MAX_INT = 536870912
-litToStgAtom :: BasicLit -> SUniqSM (PlainStgAtom, Bag PlainStgBinding)
+litToStgArg :: Literal -> UniqSM (StgArg, Bag StgBinding)
-litToStgAtom (NoRepStr s)
- = newStgVar stringTy `thenSUs` \ var ->
+litToStgArg (NoRepStr s)
+ = newStgVar stringTy `thenUs` \ var ->
let
rhs = StgRhsClosure noCostCentre -- No cost centre (ToDo?)
stgArgOcc -- safe
bOGUS_FVs
- Updatable -- OLD: ReEntrant (see note below)
+ Updatable -- WAS: ReEntrant (see note below)
[] -- No arguments
val
-- We used not to update strings, so that they wouldn't clog up the heap,
--- but instead be unpacked each time. But on some programs that costs a lot
+-- but instead be unpacked each time. But on some programs that costs a lot
-- [eg hpg], so now we update them.
val = if (any is_NUL (_UNPK_ s)) then -- must cater for NULs in literal string
- StgApp (StgVarAtom unpackCString2Id)
- [StgLitAtom (MachStr s),
- StgLitAtom (mkMachInt (toInteger (_LENGTH_ s)))]
+ StgApp (StgVarArg unpackCString2Id)
+ [StgLitArg (MachStr s),
+ StgLitArg (mkMachInt (toInteger (_LENGTH_ s)))]
bOGUS_LVs
else
- StgApp (StgVarAtom unpackCStringId)
- [StgLitAtom (MachStr s)]
+ StgApp (StgVarArg unpackCStringId)
+ [StgLitArg (MachStr s)]
bOGUS_LVs
in
- returnSUs (StgVarAtom var, unitBag (StgNonRec var rhs))
+ returnUs (StgVarArg var, unitBag (StgNonRec var rhs))
where
is_NUL c = c == '\0'
-litToStgAtom (NoRepInteger i)
+litToStgArg (NoRepInteger i)
-- extremely convenient to look out for a few very common
-- Integer literals!
- | i == 0 = returnSUs (StgVarAtom integerZeroId, emptyBag)
- | i == 1 = returnSUs (StgVarAtom integerPlusOneId, emptyBag)
- | i == 2 = returnSUs (StgVarAtom integerPlusTwoId, emptyBag)
- | i == (-1) = returnSUs (StgVarAtom integerMinusOneId, emptyBag)
+ | i == 0 = returnUs (StgVarArg integerZeroId, emptyBag)
+ | i == 1 = returnUs (StgVarArg integerPlusOneId, emptyBag)
+ | i == 2 = returnUs (StgVarArg integerPlusTwoId, emptyBag)
+ | i == (-1) = returnUs (StgVarArg integerMinusOneId, emptyBag)
| otherwise
- = newStgVar integerTy `thenSUs` \ var ->
+ = newStgVar integerTy `thenUs` \ var ->
let
rhs = StgRhsClosure noCostCentre -- No cost centre (ToDo?)
stgArgOcc -- safe
[] -- No arguments
val
- val
+ val
| i > tARGET_MIN_INT && i < tARGET_MAX_INT
= -- Start from an Int
- StgPrimApp Int2IntegerOp [StgLitAtom (mkMachInt i)] bOGUS_LVs
+ StgPrim Int2IntegerOp [StgLitArg (mkMachInt i)] bOGUS_LVs
| otherwise
= -- Start from a string
- StgPrimApp Addr2IntegerOp [StgLitAtom (MachStr (_PK_ (show i)))] bOGUS_LVs
+ StgPrim Addr2IntegerOp [StgLitArg (MachStr (_PK_ (show i)))] bOGUS_LVs
in
- returnSUs (StgVarAtom var, unitBag (StgNonRec var rhs))
+ returnUs (StgVarArg var, unitBag (StgNonRec var rhs))
-litToStgAtom (NoRepRational r)
- = litToStgAtom (NoRepInteger (numerator r)) `thenSUs` \ (num_atom, binds1) ->
- litToStgAtom (NoRepInteger (denominator r)) `thenSUs` \ (denom_atom, binds2) ->
- newStgVar rationalTy `thenSUs` \ var ->
+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
+ ratioDataCon -- Constructor
[num_atom, denom_atom]
in
- returnSUs (StgVarAtom var, binds1 `unionBags`
+ returnUs (StgVarArg var, binds1 `unionBags`
binds2 `unionBags`
unitBag (StgNonRec var rhs))
-litToStgAtom other_lit = returnSUs (StgLitAtom other_lit, emptyBag)
+litToStgArg other_lit = returnUs (StgLitArg other_lit, emptyBag)
\end{code}
%************************************************************************
\begin{code}
-coreAtomToStg :: StgEnv -> PlainCoreAtom -> SUniqSM (PlainStgAtom, Bag PlainStgBinding)
+coreAtomToStg :: StgEnv -> CoreArg -> UniqSM (StgArg, Bag StgBinding)
-coreAtomToStg env (CoVarAtom var) = returnSUs (stgLookup env var, emptyBag)
-coreAtomToStg env (CoLitAtom lit) = litToStgAtom lit
+coreAtomToStg env (VarArg var) = returnUs (stgLookup env var, emptyBag)
+coreAtomToStg env (LitArg lit) = litToStgArg lit
\end{code}
There's not anything interesting we can ASSERT about \tr{var} if it
isn't in the StgEnv. (WDP 94/06)
\begin{code}
-stgLookup :: StgEnv -> Id -> PlainStgAtom
+stgLookup :: StgEnv -> Id -> StgArg
stgLookup env var = case (lookupIdEnv env var) of
- Nothing -> StgVarAtom var
+ Nothing -> StgVarArg var
Just atom -> atom
\end{code}
%************************************************************************
\begin{code}
-coreExprToStg :: StgEnv
- -> PlainCoreExpr
- -> SUniqSM (PlainStgExpr, -- Result
- Bag PlainStgBinding) -- Float these to top level
+coreExprToStg :: StgEnv
+ -> CoreExpr
+ -> UniqSM (StgExpr, -- Result
+ Bag StgBinding) -- Float these to top level
\end{code}
\begin{code}
-coreExprToStg env (CoLit lit)
- = litToStgAtom lit `thenSUs` \ (atom, binds) ->
- returnSUs (StgApp atom [] bOGUS_LVs, binds)
+coreExprToStg env (Lit lit)
+ = litToStgArg lit `thenUs` \ (atom, binds) ->
+ returnUs (StgApp atom [] bOGUS_LVs, binds)
-coreExprToStg env (CoVar var)
- = returnSUs (StgApp (stgLookup env var) [] bOGUS_LVs, emptyBag)
+coreExprToStg env (Var var)
+ = returnUs (StgApp (stgLookup env var) [] bOGUS_LVs, emptyBag)
-coreExprToStg env (CoCon con types args)
- = mapAndUnzipSUs (coreAtomToStg env) args `thenSUs` \ (stg_atoms, stg_binds) ->
- returnSUs (StgConApp spec_con stg_atoms bOGUS_LVs, unionManyBags stg_binds)
+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 (CoPrim op tys args)
- = mapAndUnzipSUs (coreAtomToStg env) args `thenSUs` \ (stg_atoms, stg_binds) ->
- returnSUs (StgPrimApp op stg_atoms bOGUS_LVs, unionManyBags stg_binds)
+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}
%************************************************************************
%************************************************************************
\begin{code}
-coreExprToStg env expr@(CoLam binders body)
- = coreExprToStg env body `thenSUs` \ (stg_body, binds) ->
- newStgVar (typeOfCoreExpr expr) `thenSUs` \ var ->
- returnSUs (StgLet (StgNonRec var (StgRhsClosure noCostCentre
- stgArgOcc
- bOGUS_FVs
- ReEntrant -- binders is non-empty
- binders
- stg_body))
- (StgApp (StgVarAtom var) [] bOGUS_LVs),
- binds)
+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)
\end{code}
%************************************************************************
%************************************************************************
\begin{code}
-coreExprToStg env expr@(CoApp _ _)
+coreExprToStg env expr@(App _ _)
= -- Deal with the arguments
- mapAndUnzipSUs (coreAtomToStg env) args `thenSUs` \ (stg_args, arg_binds) ->
+ mapAndUnzipUs (coreAtomToStg env) args `thenUs` \ (stg_args, arg_binds) ->
-- Now deal with the function
- case fun of
- CoVar fun_id -> returnSUs (StgApp (stgLookup env fun_id) stg_args bOGUS_LVs,
+ case fun of
+ Var fun_id -> returnUs (StgApp (stgLookup env fun_id) stg_args bOGUS_LVs,
unionManyBags arg_binds)
other -> -- A non-variable applied to things; better let-bind it.
- newStgVar (typeOfCoreExpr fun) `thenSUs` \ fun_id ->
- coreExprToStg env fun `thenSUs` \ (stg_fun, fun_binds) ->
+ newStgVar (coreExprType fun) `thenUs` \ fun_id ->
+ coreExprToStg env fun `thenUs` \ (stg_fun, fun_binds) ->
let
fun_rhs = StgRhsClosure noCostCentre -- No cost centre (ToDo?)
stgArgOcc
[]
stg_fun
in
- returnSUs (StgLet (StgNonRec fun_id fun_rhs)
- (StgApp (StgVarAtom fun_id) stg_args bOGUS_LVs),
- unionManyBags arg_binds `unionBags`
+ returnUs (StgLet (StgNonRec fun_id fun_rhs)
+ (StgApp (StgVarArg fun_id) stg_args bOGUS_LVs),
+ unionManyBags arg_binds `unionBags`
fun_binds)
where
(fun,args) = collect_args expr []
- -- Collect arguments, discarding type applications
- collect_args (CoApp fun arg) args = collect_args fun (arg:args)
- collect_args (CoTyApp e t) args = collect_args e args
+ -- 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)
\end{code}
\begin{code}
-coreExprToStg env (CoCase discrim@(CoPrim op tys args) alts)
+coreExprToStg env (Case discrim@(Prim op tys args) alts)
| funnyParallelOp op =
- getSUnique `thenSUs` \ uniq ->
- coreExprToStg env discrim `thenSUs` \ (stg_discrim, discrim_binds) ->
- alts_to_stg alts `thenSUs` \ (stg_alts, alts_binds) ->
- returnSUs (
+ getUnique `thenUs` \ uniq ->
+ coreExprToStg env discrim `thenUs` \ (stg_discrim, discrim_binds) ->
+ alts_to_stg alts `thenUs` \ (stg_alts, alts_binds) ->
+ returnUs (
StgCase stg_discrim
bOGUS_LVs
bOGUS_LVs
funnyParallelOp ForkOp = True
funnyParallelOp _ = False
- discrim_ty = typeOfCoreExpr discrim
+ discrim_ty = coreExprType discrim
- alts_to_stg (CoPrimAlts _ (CoBindDefault binder rhs))
- = coreExprToStg env rhs `thenSUs` \ (stg_rhs, rhs_binds) ->
- let
- stg_deflt = StgBindDefault binder False stg_rhs
- in
- returnSUs (StgPrimAlts discrim_ty [] stg_deflt, rhs_binds)
+ alts_to_stg (PrimAlts _ (BindDefault binder rhs))
+ = coreExprToStg env rhs `thenUs` \ (stg_rhs, rhs_binds) ->
+ let
+ stg_deflt = StgBindDefault binder False stg_rhs
+ in
+ returnUs (StgPrimAlts discrim_ty [] stg_deflt, rhs_binds)
-- OK, back to real life...
-coreExprToStg env (CoCase discrim alts)
- = coreExprToStg env discrim `thenSUs` \ (stg_discrim, discrim_binds) ->
- alts_to_stg discrim alts `thenSUs` \ (stg_alts, alts_binds) ->
- getSUnique `thenSUs` \ uniq ->
- returnSUs (
+coreExprToStg env (Case discrim alts)
+ = coreExprToStg env discrim `thenUs` \ (stg_discrim, discrim_binds) ->
+ alts_to_stg discrim alts `thenUs` \ (stg_alts, alts_binds) ->
+ getUnique `thenUs` \ uniq ->
+ returnUs (
StgCase stg_discrim
bOGUS_LVs
bOGUS_LVs
discrim_binds `unionBags` alts_binds
)
where
- discrim_ty = typeOfCoreExpr discrim
- (_, discrim_ty_args, _) = getUniDataTyCon discrim_ty
+ discrim_ty = coreExprType discrim
+ (_, discrim_ty_args, _) = getAppDataTyCon discrim_ty
- alts_to_stg discrim (CoAlgAlts alts deflt)
- = default_to_stg discrim deflt `thenSUs` \ (stg_deflt, deflt_binds) ->
- mapAndUnzipSUs boxed_alt_to_stg alts `thenSUs` \ (stg_alts, alts_binds) ->
- returnSUs (StgAlgAlts discrim_ty stg_alts stg_deflt,
+ alts_to_stg discrim (AlgAlts alts deflt)
+ = default_to_stg discrim deflt `thenUs` \ (stg_deflt, deflt_binds) ->
+ mapAndUnzipUs boxed_alt_to_stg alts `thenUs` \ (stg_alts, alts_binds) ->
+ returnUs (StgAlgAlts discrim_ty stg_alts stg_deflt,
deflt_binds `unionBags` unionManyBags alts_binds)
where
boxed_alt_to_stg (con, bs, rhs)
- = coreExprToStg env rhs `thenSUs` \ (stg_rhs, rhs_binds) ->
- returnSUs ((spec_con, bs, [ True | b <- bs ]{-bogus use mask-}, stg_rhs),
+ = coreExprToStg env rhs `thenUs` \ (stg_rhs, rhs_binds) ->
+ returnUs ((spec_con, bs, [ True | b <- bs ]{-bogus use mask-}, stg_rhs),
rhs_binds)
where
spec_con = mkSpecialisedCon con discrim_ty_args
- alts_to_stg discrim (CoPrimAlts alts deflt)
- = default_to_stg discrim deflt `thenSUs` \ (stg_deflt,deflt_binds) ->
- mapAndUnzipSUs unboxed_alt_to_stg alts `thenSUs` \ (stg_alts, alts_binds) ->
- returnSUs (StgPrimAlts discrim_ty stg_alts stg_deflt,
+ alts_to_stg discrim (PrimAlts alts deflt)
+ = default_to_stg discrim deflt `thenUs` \ (stg_deflt,deflt_binds) ->
+ mapAndUnzipUs unboxed_alt_to_stg alts `thenUs` \ (stg_alts, alts_binds) ->
+ returnUs (StgPrimAlts discrim_ty stg_alts stg_deflt,
deflt_binds `unionBags` unionManyBags alts_binds)
where
unboxed_alt_to_stg (lit, rhs)
- = coreExprToStg env rhs `thenSUs` \ (stg_rhs, rhs_binds) ->
- returnSUs ((lit, stg_rhs), rhs_binds)
-
-#ifdef DPH
- alts_to_stg (CoParAlgAlts tycon ctxt params alts deflt)
- = default_to_stg deflt `thenSUs` \ stg_deflt ->
- mapSUs boxed_alt_to_stg alts `thenSUs` \ stg_alts ->
- returnSUs (StgParAlgAlts discrim_ty ctxt params stg_alts stg_deflt)
- where
- boxed_alt_to_stg (con, rhs)
- = coreExprToStg env rhs `thenSUs` \ stg_rhs ->
- returnSUs (con, stg_rhs)
-
- alts_to_stg (CoParPrimAlts tycon ctxt alts deflt)
- = default_to_stg deflt `thenSUs` \ stg_deflt ->
- mapSUs unboxed_alt_to_stg alts `thenSUs` \ stg_alts ->
- returnSUs (StgParPrimAlts discrim_ty ctxt stg_alts stg_deflt)
- where
- unboxed_alt_to_stg (lit, rhs)
- = coreExprToStg env rhs `thenSUs` \ stg_rhs ->
- returnSUs (lit, stg_rhs)
-#endif {- Data Parallel Haskell -}
+ = coreExprToStg env rhs `thenUs` \ (stg_rhs, rhs_binds) ->
+ returnUs ((lit, stg_rhs), rhs_binds)
- default_to_stg discrim CoNoDefault
- = returnSUs (StgNoDefault, emptyBag)
+ default_to_stg discrim NoDefault
+ = returnUs (StgNoDefault, emptyBag)
- default_to_stg discrim (CoBindDefault binder rhs)
- = coreExprToStg new_env rhs `thenSUs` \ (stg_rhs, rhs_binds) ->
- returnSUs (StgBindDefault binder True{-used? no it is lying-} stg_rhs,
+ default_to_stg discrim (BindDefault binder rhs)
+ = coreExprToStg new_env rhs `thenUs` \ (stg_rhs, rhs_binds) ->
+ returnUs (StgBindDefault binder True{-used? no it is lying-} stg_rhs,
rhs_binds)
where
--
- -- We convert case x of {...; x' -> ...x'...}
+ -- We convert case x of {...; x' -> ...x'...}
-- to
-- case x of {...; _ -> ...x... }
--
-- default binder to the scrutinee.
--
new_env = case discrim of
- CoVar v -> addOneToIdEnv env binder (stgLookup env v)
+ Var v -> addOneToIdEnv env binder (stgLookup env v)
other -> env
\end{code}
%************************************************************************
\begin{code}
-coreExprToStg env (CoLet bind body)
- = coreBindToStg env bind `thenSUs` \ (stg_binds, new_env, float_binds1) ->
- coreExprToStg new_env body `thenSUs` \ (stg_body, float_binds2) ->
- returnSUs (mkStgLets stg_binds stg_body, float_binds1 `unionBags` float_binds2)
+coreExprToStg env (Let bind body)
+ = coreBindToStg env bind `thenUs` \ (stg_binds, new_env, float_binds1) ->
+ coreExprToStg new_env body `thenUs` \ (stg_body, float_binds2) ->
+ returnUs (mkStgLets stg_binds stg_body, float_binds1 `unionBags` float_binds2)
\end{code}
Covert core @scc@ expression directly to STG @scc@ expression.
\begin{code}
-coreExprToStg env (CoSCC cc expr)
- = coreExprToStg env expr `thenSUs` \ (stg_expr, binds) ->
- returnSUs (StgSCC (typeOfCoreExpr expr) cc stg_expr, binds)
+coreExprToStg env (SCC cc expr)
+ = coreExprToStg env expr `thenUs` \ (stg_expr, binds) ->
+ returnUs (StgSCC (coreExprType expr) cc stg_expr, binds)
\end{code}
-%************************************************************************
-%* *
-\subsubsection[coreToStg-dataParallel]{Data Parallel expressions}
-%* *
-%************************************************************************
-\begin{code}
-#ifdef DPH
-coreExprToStg env (_, AnnCoParCon con ctxt types args)
- = mapAndUnzipSUs (arg2stg env) args `thenSUs` \ (stg_atoms, stg_binds) ->
- returnSUs (mkStgLets (catMaybes stg_binds)
- (StgParConApp con ctxt stg_atoms bOGUS_LVs))
-
-coreExprToStg env (_,AnnCoParComm ctxt expr comm)
- = coreExprToStg env expr `thenSUs` \ stg_expr ->
- annComm_to_stg comm `thenSUs` \ (stg_comm,stg_binds) ->
- returnSUs (mkStgLets (catMaybes stg_binds)
- (StgParComm ctxt stg_expr stg_comm))
- ))
- where
- annComm_to_stg (AnnCoParSend args)
- = mapAndUnzipSUs (arg2stg env) args `thenSUs` \ (stg_atoms, stg_binds) ->
- returnSUs (StgParSend stg_atoms,stg_binds)
-
- annComm_to_stg (AnnCoParFetch args)
- = mapAndUnzipSUs (arg2stg env) args `thenSUs` \ (stg_atoms, stg_binds) ->
- returnSUs (StgParFetch stg_atoms,stg_binds)
-
- annComm_to_stg (AnnCoToPodized)
- = returnSUs (StgToPodized,[])
- annComm_to_stg (AnnCoFromPodized)
- = returnSUs (StgFromPodized,[])
-#endif {- Data Parallel Haskell -}
-\end{code}
-
-\begin{code}
-#ifdef DEBUG
-coreExprToStg env other = panic "coreExprToStg: it really failed here"
-#endif
-\end{code}
%************************************************************************
%* *
Invent a fresh @Id@:
\begin{code}
-newStgVar :: UniType -> SUniqSM Id
+newStgVar :: Type -> UniqSM Id
newStgVar ty
- = getSUnique `thenSUs` \ uniq ->
- returnSUs (mkSysLocal SLIT("stg") uniq ty mkUnknownSrcLoc)
+ = getUnique `thenUs` \ uniq ->
+ returnUs (mkSysLocal SLIT("stg") uniq ty mkUnknownSrcLoc)
\end{code}
\begin{code}
-mkStgLets :: [PlainStgBinding]
- -> PlainStgExpr -- body of let
- -> PlainStgExpr
+mkStgLets :: [StgBinding]
+ -> StgExpr -- body of let
+ -> StgExpr
mkStgLets binds body = foldr StgLet body binds
\end{code}
projects / ghc-hetmet.git / blobdiff