2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
4 %************************************************************************
6 \section[CoreToStg]{Converting core syntax to STG syntax}
8 %************************************************************************
10 Convert a @CoreSyntax@ program to a @StgSyntax@ program.
13 #include "HsVersions.h"
15 module CoreToStg ( topCoreBindsToStg ) where
18 IMPORT_1_3(Ratio(numerator,denominator))
20 import CoreSyn -- input
21 import StgSyn -- output
23 import Bag ( emptyBag, unitBag, unionBags, unionManyBags, bagToList )
24 import CoreUtils ( coreExprType )
25 import CostCentre ( noCostCentre )
26 import Id ( mkSysLocal, idType, isBottomingId, addIdArity,
28 nullIdEnv, addOneToIdEnv, lookupIdEnv, growIdEnvList,
29 SYN_IE(IdEnv), GenId{-instance NamedThing-}
31 import IdInfo ( ArityInfo, exactArity )
32 import Literal ( mkMachInt, Literal(..) )
33 import PrelVals ( unpackCStringId, unpackCString2Id,
34 integerZeroId, integerPlusOneId,
35 integerPlusTwoId, integerMinusOneId
37 import PrimOp ( PrimOp(..) )
38 import SpecUtils ( mkSpecialisedCon )
39 import SrcLoc ( noSrcLoc )
40 import TyCon ( TyCon{-instance Uniquable-} )
41 import Type ( maybeAppDataTyCon, getAppDataTyConExpandingDicts )
42 import TysWiredIn ( stringTy )
43 import Unique ( integerTyConKey, ratioTyConKey, Unique{-instance Eq-} )
44 import UniqSupply -- all of it, really
45 import Util ( zipLazy, panic, assertPanic{-, pprTrace ToDo:rm-} )
46 --import Pretty--ToDo:rm
47 --import PprStyle--ToDo:rm
48 --import PprType --ToDo:rm
49 --import Outputable--ToDo:rm
50 --import PprEnv--ToDo:rm
52 isLeakFreeType x y = False -- safe option; ToDo
56 *************** OVERVIEW *********************
59 The business of this pass is to convert Core to Stg. On the way:
61 * We discard type lambdas and applications. In so doing we discard
62 "trivial" bindings such as
64 where t1, t2 are types
66 * We pin correct arities on each let(rec)-bound binder, and propagate them
67 to their uses. This is used
68 a) when emitting arity info into interface files
69 b) in the code generator, when deciding if a right-hand side
70 is a saturated application so we can generate a VAP closure.
71 (b) is rather untidy, but the easiest compromise was to propagate arities here.
73 * We do *not* pin on the correct free/live var info; that's done later.
74 Instead we use bOGUS_LVS and _FVS as a placeholder.
76 [Quite a bit of stuff that used to be here has moved
77 to tidyCorePgm (SimplCore.lhs) SLPJ Nov 96]
80 %************************************************************************
82 \subsection[coreToStg-programs]{Converting a core program and core bindings}
84 %************************************************************************
86 Because we're going to come across ``boring'' bindings like
87 \tr{let x = /\ tyvars -> y in ...}, we want to keep a small
88 environment, so we can just replace all occurrences of \tr{x}
92 type StgEnv = IdEnv StgArg
95 No free/live variable information is pinned on in this pass; it's added
97 we use @bOGUS_LVs@ and @bOGUS_FVs@ as placeholders.
100 bOGUS_LVs :: StgLiveVars
101 bOGUS_LVs = panic "bOGUS_LVs" -- emptyUniqSet (used when pprTracing)
104 bOGUS_FVs = panic "bOGUS_FVs" -- [] (ditto)
108 topCoreBindsToStg :: UniqSupply -- name supply
109 -> [CoreBinding] -- input
110 -> [StgBinding] -- output
112 topCoreBindsToStg us core_binds
113 = case (initUs us (coreBindsToStg nullIdEnv core_binds)) of
116 coreBindsToStg :: StgEnv -> [CoreBinding] -> UniqSM [StgBinding]
118 coreBindsToStg env [] = returnUs []
119 coreBindsToStg env (b:bs)
120 = coreBindToStg env b `thenUs` \ (new_b, new_env) ->
121 coreBindsToStg new_env bs `thenUs` \ new_bs ->
122 returnUs (new_b ++ new_bs)
125 %************************************************************************
127 \subsection[coreToStg-binds]{Converting bindings}
129 %************************************************************************
132 coreBindToStg :: StgEnv
134 -> UniqSM ([StgBinding], -- Empty or singleton
137 coreBindToStg env (NonRec binder rhs)
138 = coreRhsToStg env rhs `thenUs` \ stg_rhs ->
140 -- Binds to return if RHS is trivial
141 binder_w_arity = binder `addIdArity` (rhsArity stg_rhs)
142 triv_binds | externallyVisibleId binder = [StgNonRec binder_w_arity stg_rhs] -- Retain it
143 | otherwise = [] -- Discard it
146 StgRhsClosure cc bi fvs upd [] (StgApp atom [] lvs) ->
147 -- Trivial RHS, so augment envt, and ditch the binding
148 returnUs (triv_binds, new_env)
150 new_env = addOneToIdEnv env binder atom
152 StgRhsCon cc con_id [] ->
153 -- Trivial RHS, so augment envt, and ditch the binding
154 returnUs (triv_binds, new_env)
156 new_env = addOneToIdEnv env binder (StgConArg con_id)
158 other -> -- Non-trivial RHS, so don't augment envt
159 returnUs ([StgNonRec binder_w_arity stg_rhs], new_env)
161 new_env = addOneToIdEnv env binder (StgVarArg binder_w_arity)
162 -- new_env propagates the arity
164 coreBindToStg env (Rec pairs)
165 = -- NB: *** WE DO NOT CHECK FOR TRIV_BINDS in REC BIND ****
168 (binders, rhss) = unzip pairs
170 mapUs (coreRhsToStg env) rhss `thenUs` \ stg_rhss ->
172 binders_w_arities = [ b `addIdArity` rhsArity rhs
173 | (b,rhs) <- binders `zip` stg_rhss]
175 returnUs ([StgRec (binders_w_arities `zip` stg_rhss)], env)
177 rhsArity (StgRhsClosure _ _ _ _ args _) = exactArity (length args)
178 rhsArity (StgRhsCon _ _ _) = exactArity 0
182 %************************************************************************
184 \subsection[coreToStg-rhss]{Converting right hand sides}
186 %************************************************************************
189 coreRhsToStg :: StgEnv -> CoreExpr -> UniqSM StgRhs
191 coreRhsToStg env core_rhs
192 = coreExprToStg env core_rhs `thenUs` \ stg_expr ->
194 let stg_rhs = case stg_expr of
195 StgLet (StgNonRec var1 rhs) (StgApp (StgVarArg var2) [] _)
196 | var1 == var2 -> rhs
197 -- This curious stuff is to unravel what a lambda turns into
198 -- We have to do it this way, rather than spot a lambda in the
199 -- incoming rhs. Why? Because trivial bindings might conceal
200 -- what the rhs is actually like.
202 StgCon con args _ -> StgRhsCon noCostCentre con args
204 other -> StgRhsClosure noCostCentre -- No cost centre (ToDo?)
207 Updatable -- Be pessimistic
215 %************************************************************************
217 \subsection[coreToStg-atoms{Converting atoms}
219 %************************************************************************
222 coreArgsToStg :: StgEnv -> [CoreArg] -> ([Type], [StgArg])
224 coreArgsToStg env [] = ([], [])
225 coreArgsToStg env (a:as)
227 TyArg t -> (t:trest, vrest)
228 UsageArg u -> (trest, vrest)
229 VarArg v -> (trest, stgLookup env v : vrest)
230 LitArg l -> (trest, StgLitArg l : vrest)
232 (trest,vrest) = coreArgsToStg env as
236 %************************************************************************
238 \subsection[coreToStg-exprs]{Converting core expressions}
240 %************************************************************************
243 coreExprToStg :: StgEnv -> CoreExpr -> UniqSM StgExpr
245 coreExprToStg env (Lit lit)
246 = returnUs (StgApp (StgLitArg lit) [] bOGUS_LVs)
248 coreExprToStg env (Var var)
249 = returnUs (mk_app (stgLookup env var) [])
251 coreExprToStg env (Con con args)
253 (types, stg_atoms) = coreArgsToStg env args
254 spec_con = mkSpecialisedCon con types
256 returnUs (StgCon spec_con stg_atoms bOGUS_LVs)
258 coreExprToStg env (Prim op args)
260 (types, stg_atoms) = coreArgsToStg env args
262 returnUs (StgPrim op stg_atoms bOGUS_LVs)
265 %************************************************************************
267 \subsubsection[coreToStg-lambdas]{Lambda abstractions}
269 %************************************************************************
272 coreExprToStg env expr@(Lam _ _)
274 (_,_, binders, body) = collectBinders expr
276 coreExprToStg env body `thenUs` \ stg_body ->
278 if null binders then -- it was all type/usage binders; tossed
281 newStgVar (coreExprType expr) `thenUs` \ var ->
283 (StgLet (StgNonRec (var `addIdArity` exactArity (length binders))
284 (StgRhsClosure noCostCentre
287 ReEntrant -- binders is non-empty
290 (StgApp (StgVarArg var) [] bOGUS_LVs))
293 %************************************************************************
295 \subsubsection[coreToStg-applications]{Applications}
297 %************************************************************************
300 coreExprToStg env expr@(App _ _)
302 (fun,args) = collect_args expr []
303 (_, stg_args) = coreArgsToStg env args
305 -- Now deal with the function
307 (Var fun_id, _) -> -- A function Id, so do an StgApp; it's ok if
308 -- there are no arguments.
309 returnUs (mk_app (stgLookup env fun_id) stg_args)
311 (non_var_fun, []) -> -- No value args, so recurse into the function
312 coreExprToStg env non_var_fun
314 other -> -- A non-variable applied to things; better let-bind it.
315 newStgVar (coreExprType fun) `thenUs` \ fun_id ->
316 coreExprToStg env fun `thenUs` \ (stg_fun) ->
318 fun_rhs = StgRhsClosure noCostCentre -- No cost centre (ToDo?)
321 SingleEntry -- Only entered once
325 returnUs (StgLet (StgNonRec fun_id fun_rhs)
326 (StgApp (StgVarArg fun_id) stg_args bOGUS_LVs))
328 -- Collect arguments, discarding type/usage applications
329 collect_args (App e (TyArg _)) args = collect_args e args
330 collect_args (App e (UsageArg _)) args = collect_args e args
331 collect_args (App fun arg) args = collect_args fun (arg:args)
332 collect_args fun args = (fun, args)
335 %************************************************************************
337 \subsubsection[coreToStg-cases]{Case expressions}
339 %************************************************************************
342 coreExprToStg env (Case discrim alts)
343 = coreExprToStg env discrim `thenUs` \ stg_discrim ->
344 alts_to_stg discrim alts `thenUs` \ stg_alts ->
345 getUnique `thenUs` \ uniq ->
354 discrim_ty = coreExprType discrim
355 (_, discrim_ty_args, _) = getAppDataTyConExpandingDicts discrim_ty
357 alts_to_stg discrim (AlgAlts alts deflt)
358 = default_to_stg discrim deflt `thenUs` \ stg_deflt ->
359 mapUs boxed_alt_to_stg alts `thenUs` \ stg_alts ->
360 returnUs (StgAlgAlts discrim_ty stg_alts stg_deflt)
362 boxed_alt_to_stg (con, bs, rhs)
363 = coreExprToStg env rhs `thenUs` \ stg_rhs ->
364 returnUs (spec_con, bs, [ True | b <- bs ]{-bogus use mask-}, stg_rhs)
366 spec_con = mkSpecialisedCon con discrim_ty_args
368 alts_to_stg discrim (PrimAlts alts deflt)
369 = default_to_stg discrim deflt `thenUs` \ stg_deflt ->
370 mapUs unboxed_alt_to_stg alts `thenUs` \ stg_alts ->
371 returnUs (StgPrimAlts discrim_ty stg_alts stg_deflt)
373 unboxed_alt_to_stg (lit, rhs)
374 = coreExprToStg env rhs `thenUs` \ stg_rhs ->
375 returnUs (lit, stg_rhs)
377 default_to_stg discrim NoDefault
378 = returnUs StgNoDefault
380 default_to_stg discrim (BindDefault binder rhs)
381 = coreExprToStg env rhs `thenUs` \ stg_rhs ->
382 returnUs (StgBindDefault binder True{-used? no it is lying-} stg_rhs)
385 %************************************************************************
387 \subsubsection[coreToStg-let(rec)]{Let and letrec expressions}
389 %************************************************************************
392 coreExprToStg env (Let bind body)
393 = coreBindToStg env bind `thenUs` \ (stg_binds, new_env) ->
394 coreExprToStg new_env body `thenUs` \ stg_body ->
395 returnUs (mkStgLets stg_binds stg_body)
399 %************************************************************************
401 \subsubsection[coreToStg-scc]{SCC expressions}
403 %************************************************************************
405 Covert core @scc@ expression directly to STG @scc@ expression.
407 coreExprToStg env (SCC cc expr)
408 = coreExprToStg env expr `thenUs` \ stg_expr ->
409 returnUs (StgSCC (coreExprType expr) cc stg_expr)
413 coreExprToStg env (Coerce c ty expr) = coreExprToStg env expr
417 %************************************************************************
419 \subsection[coreToStg-misc]{Miscellaneous helping functions}
421 %************************************************************************
423 There's not anything interesting we can ASSERT about \tr{var} if it
424 isn't in the StgEnv. (WDP 94/06)
427 stgLookup :: StgEnv -> Id -> StgArg
428 stgLookup env var = case (lookupIdEnv env var) of
429 Nothing -> StgVarArg var
435 newStgVar :: Type -> UniqSM Id
437 = getUnique `thenUs` \ uniq ->
438 returnUs (mkSysLocal SLIT("stg") uniq ty noSrcLoc)
442 mkStgLets :: [StgBinding]
443 -> StgExpr -- body of let
446 mkStgLets binds body = foldr StgLet body binds
448 -- mk_app spots an StgCon in a function position,
449 -- and turns it into an StgCon. See notes with
450 -- getArgAmode in CgBindery.
451 mk_app (StgConArg con) args = StgCon con args bOGUS_LVs
452 mk_app other_fun args = StgApp other_fun args bOGUS_LVs