Convert a @CoreSyntax@ program to a @StgSyntax@ program.
\begin{code}
-#include "HsVersions.h"
-
module CoreToStg ( topCoreBindsToStg ) where
-IMP_Ubiq(){-uitous-}
-IMPORT_1_3(Ratio(numerator,denominator))
+#include "HsVersions.h"
import CoreSyn -- input
import StgSyn -- output
-import Bag ( emptyBag, unitBag, unionBags, unionManyBags, bagToList )
import CoreUtils ( coreExprType )
import CostCentre ( noCostCentre )
-import Id ( mkSysLocal, idType, isBottomingId,
- externallyVisibleId,
- nullIdEnv, addOneToIdEnv, lookupIdEnv, growIdEnvList,
- SYN_IE(IdEnv), GenId{-instance NamedThing-}, SYN_IE(Id)
+import MkId ( mkSysLocal )
+import Id ( externallyVisibleId, mkIdWithNewUniq,
+ nullIdEnv, addOneToIdEnv, lookupIdEnv,
+ IdEnv, Id
)
-import Literal ( mkMachInt, Literal(..) )
-import PrelVals ( unpackCStringId, unpackCString2Id,
- integerZeroId, integerPlusOneId,
- integerPlusTwoId, integerMinusOneId
- )
-import PrimOp ( PrimOp(..) )
-import SpecUtils ( mkSpecialisedCon )
import SrcLoc ( noSrcLoc )
-import TyCon ( TyCon{-instance Uniquable-} )
-import Type ( maybeAppDataTyCon, getAppDataTyConExpandingDicts, SYN_IE(Type) )
-import TysWiredIn ( stringTy )
-import Unique ( integerTyConKey, ratioTyConKey, Unique{-instance Eq-} )
-import UniqSupply -- all of it, really
-import Util ( zipLazy, 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
+import Type ( splitAlgTyConApp, Type )
+import UniqSupply ( UniqSupply, UniqSM,
+ returnUs, thenUs, initUs,
+ mapUs, getUnique
+ )
+import Outputable ( panic )
isLeakFreeType x y = False -- safe option; ToDo
\end{code}
environment, so we can just replace all occurrences of \tr{x}
with \tr{y}.
+March 98: We also use this environment to give all locally bound
+Names new unique ids, since the code generator assumes that binders
+are unique across a module. (Simplifier doesn't maintain this
+invariant any longer.)
+
\begin{code}
type StgEnv = IdEnv StgArg
\end{code}
where
new_env = addOneToIdEnv env binder (StgConArg con_id)
- other -> -- Non-trivial RHS, so don't augment envt
- returnUs ([StgNonRec binder stg_rhs], env)
+ other -> -- Non-trivial RHS
+ mkUniqueBinder env binder `thenUs` \ (new_env, new_binder) ->
+ returnUs ([StgNonRec new_binder stg_rhs], new_env)
+ where
+ mkUniqueBinder env binder
+ | externallyVisibleId binder = returnUs (env, binder)
+ | otherwise =
+ -- local binder, give it a new unique Id.
+ newUniqueLocalId binder `thenUs` \ binder' ->
+ let
+ new_env = addOneToIdEnv env binder (StgVarArg binder')
+ in
+ returnUs (new_env, binder')
+
coreBindToStg env (Rec pairs)
= -- NB: *** WE DO NOT CHECK FOR TRIV_BINDS in REC BIND ****
let
(binders, rhss) = unzip pairs
in
- mapUs (coreRhsToStg env) rhss `thenUs` \ stg_rhss ->
- returnUs ([StgRec (binders `zip` stg_rhss)], env)
+ newLocalIds env True{-maybe externally visible-} binders `thenUs` \ (binders', env') ->
+ mapUs (coreRhsToStg env') rhss `thenUs` \ stg_rhss ->
+ returnUs ([StgRec (binders' `zip` stg_rhss)], env')
\end{code}
coreArgsToStg env (a:as)
= case a of
TyArg t -> (t:trest, vrest)
- UsageArg u -> (trest, vrest)
VarArg v -> (trest, stgLookup env v : vrest)
LitArg l -> (trest, StgLitArg l : vrest)
where
coreExprToStg env (Con con args)
= let
(types, stg_atoms) = coreArgsToStg env args
- spec_con = mkSpecialisedCon con types
in
- returnUs (StgCon spec_con stg_atoms bOGUS_LVs)
+ returnUs (StgCon con stg_atoms bOGUS_LVs)
coreExprToStg env (Prim op args)
= let
\begin{code}
coreExprToStg env expr@(Lam _ _)
= let
- (_,_, binders, body) = collectBinders expr
+ (_, binders, body) = collectBinders expr
in
- coreExprToStg env body `thenUs` \ stg_body ->
+ newLocalIds env False{-all local-} binders `thenUs` \ (binders', env') ->
+ coreExprToStg env' body `thenUs` \ stg_body ->
if null binders then -- it was all type/usage binders; tossed
returnUs stg_body
stgArgOcc
bOGUS_FVs
ReEntrant -- binders is non-empty
- binders
+ binders'
stg_body))
(StgApp (StgVarArg var) [] bOGUS_LVs))
\end{code}
(StgApp (StgVarArg fun_id) stg_args bOGUS_LVs))
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)
+ collect_args (App e (TyArg _)) args = collect_args e args
+ collect_args (App fun arg) args = collect_args fun (arg:args)
+ collect_args (Note (Coerce _ _) expr) args = collect_args expr args
+ collect_args (Note InlineCall expr) args = collect_args expr args
+ collect_args fun args = (fun, args)
\end{code}
%************************************************************************
%* *
%************************************************************************
+
+******* TO DO TO DO: fix what follows
+
+Special case for
+
+ case (op x1 ... xn) of
+ y -> e
+
+where the type of the case scrutinee is a multi-constuctor algebraic type.
+Then we simply compile code for
+
+ let y = op x1 ... xn
+ in
+ e
+
+In this case:
+
+ case (op x1 ... xn) of
+ C a b -> ...
+ y -> e
+
+where the type of the case scrutinee is a multi-constuctor algebraic type.
+we just bomb out at the moment. It never happens in practice.
+
+**** END OF TO DO TO DO
+
\begin{code}
+coreExprToStg env (Case scrut@(Prim op args) (AlgAlts alts (BindDefault binder rhs)))
+ = if not (null alts) then
+ panic "cgCase: case on PrimOp with default *and* alts\n"
+ -- For now, die if alts are non-empty
+ else
+ coreExprToStg env (Let (NonRec binder scrut) rhs)
+
coreExprToStg env (Case discrim alts)
= coreExprToStg env discrim `thenUs` \ stg_discrim ->
alts_to_stg discrim alts `thenUs` \ stg_alts ->
)
where
discrim_ty = coreExprType discrim
- (_, discrim_ty_args, _) = getAppDataTyConExpandingDicts discrim_ty
+ (_, discrim_ty_args, _) = splitAlgTyConApp discrim_ty
alts_to_stg discrim (AlgAlts alts deflt)
= default_to_stg discrim deflt `thenUs` \ stg_deflt ->
where
boxed_alt_to_stg (con, bs, rhs)
= coreExprToStg env rhs `thenUs` \ stg_rhs ->
- returnUs (spec_con, bs, [ True | b <- bs ]{-bogus use mask-}, stg_rhs)
- where
- spec_con = mkSpecialisedCon con discrim_ty_args
+ returnUs (con, bs, [ True | b <- bs ]{-bogus use mask-}, stg_rhs)
alts_to_stg discrim (PrimAlts alts deflt)
= default_to_stg discrim deflt `thenUs` \ stg_deflt ->
Covert core @scc@ expression directly to STG @scc@ expression.
\begin{code}
-coreExprToStg env (SCC cc expr)
+coreExprToStg env (Note (SCC cc) expr)
= coreExprToStg env expr `thenUs` \ stg_expr ->
returnUs (StgSCC (coreExprType expr) cc stg_expr)
\end{code}
\begin{code}
-coreExprToStg env (Coerce c ty expr) = coreExprToStg env expr
+coreExprToStg env (Note other_note expr) = coreExprToStg env expr
\end{code}
\end{code}
\begin{code}
+newUniqueLocalId :: Id -> UniqSM Id
+newUniqueLocalId i =
+ getUnique `thenUs` \ uniq ->
+ returnUs (mkIdWithNewUniq i uniq)
+
+newLocalIds :: StgEnv -> Bool -> [Id] -> UniqSM ([Id], StgEnv)
+newLocalIds env maybe_visible [] = returnUs ([], env)
+newLocalIds env maybe_visible (i:is)
+ | maybe_visible && externallyVisibleId i =
+ newLocalIds env maybe_visible is `thenUs` \ (is', env') ->
+ returnUs (i:is', env')
+ | otherwise =
+ newUniqueLocalId i `thenUs` \ i' ->
+ let
+ new_env = addOneToIdEnv env i (StgVarArg i')
+ in
+ newLocalIds new_env maybe_visible is `thenUs` \ (is', env') ->
+ returnUs (i':is', env')
+\end{code}
+
+
+\begin{code}
mkStgLets :: [StgBinding]
-> StgExpr -- body of let
-> StgExpr
projects / ghc-hetmet.git / blobdiff