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 module CoreToStg ( topCoreBindsToStg ) where
15 #include "HsVersions.h"
17 import CoreSyn -- input
18 import StgSyn -- output
20 import Bag ( emptyBag, unitBag, unionBags, unionManyBags, bagToList )
21 import CoreUtils ( coreExprType )
22 import CostCentre ( noCostCentre )
23 import Id ( mkSysLocal, idType, isBottomingId,
26 nullIdEnv, addOneToIdEnv, lookupIdEnv, growIdEnvList,
27 IdEnv, GenId{-instance NamedThing-}, Id
29 import Literal ( mkMachInt, Literal(..) )
30 import PrelVals ( unpackCStringId, unpackCString2Id,
31 integerZeroId, integerPlusOneId,
32 integerPlusTwoId, integerMinusOneId
34 import PrimOp ( PrimOp(..) )
35 import SrcLoc ( noSrcLoc )
36 import TyCon ( TyCon{-instance Uniquable-} )
37 import Type ( splitAlgTyConApp, Type )
38 import TysWiredIn ( stringTy )
39 import Unique ( integerTyConKey, ratioTyConKey, Unique{-instance Eq-} )
40 import UniqSupply -- all of it, really
41 import Util ( zipLazy )
43 import Ratio ( numerator, denominator )
45 isLeakFreeType x y = False -- safe option; ToDo
49 *************** OVERVIEW *********************
52 The business of this pass is to convert Core to Stg. On the way:
54 * We discard type lambdas and applications. In so doing we discard
55 "trivial" bindings such as
57 where t1, t2 are types
59 * We don't pin on correct arities any more, because they can be mucked up
60 by the lambda lifter. In particular, the lambda lifter can take a local
61 letrec-bound variable and make it a lambda argument, which shouldn't have
62 an arity. So SetStgVarInfo sets arities now.
64 * We do *not* pin on the correct free/live var info; that's done later.
65 Instead we use bOGUS_LVS and _FVS as a placeholder.
67 [Quite a bit of stuff that used to be here has moved
68 to tidyCorePgm (SimplCore.lhs) SLPJ Nov 96]
71 %************************************************************************
73 \subsection[coreToStg-programs]{Converting a core program and core bindings}
75 %************************************************************************
77 Because we're going to come across ``boring'' bindings like
78 \tr{let x = /\ tyvars -> y in ...}, we want to keep a small
79 environment, so we can just replace all occurrences of \tr{x}
83 type StgEnv = IdEnv StgArg
86 No free/live variable information is pinned on in this pass; it's added
88 we use @bOGUS_LVs@ and @bOGUS_FVs@ as placeholders.
91 bOGUS_LVs :: StgLiveVars
92 bOGUS_LVs = panic "bOGUS_LVs" -- emptyUniqSet (used when pprTracing)
95 bOGUS_FVs = panic "bOGUS_FVs" -- [] (ditto)
99 topCoreBindsToStg :: UniqSupply -- name supply
100 -> [CoreBinding] -- input
101 -> [StgBinding] -- output
103 topCoreBindsToStg us core_binds
104 = initUs us (coreBindsToStg nullIdEnv core_binds)
106 coreBindsToStg :: StgEnv -> [CoreBinding] -> UniqSM [StgBinding]
108 coreBindsToStg env [] = returnUs []
109 coreBindsToStg env (b:bs)
110 = coreBindToStg env b `thenUs` \ (new_b, new_env) ->
111 coreBindsToStg new_env bs `thenUs` \ new_bs ->
112 returnUs (new_b ++ new_bs)
115 %************************************************************************
117 \subsection[coreToStg-binds]{Converting bindings}
119 %************************************************************************
122 coreBindToStg :: StgEnv
124 -> UniqSM ([StgBinding], -- Empty or singleton
127 coreBindToStg env (NonRec binder rhs)
128 = coreRhsToStg env rhs `thenUs` \ stg_rhs ->
130 -- Binds to return if RHS is trivial
131 triv_binds | externallyVisibleId binder = [StgNonRec binder stg_rhs] -- Retain it
132 | otherwise = [] -- Discard it
135 StgRhsClosure cc bi fvs upd [] (StgApp atom [] lvs) ->
136 -- Trivial RHS, so augment envt, and ditch the binding
137 returnUs (triv_binds, new_env)
139 new_env = addOneToIdEnv env binder atom
141 StgRhsCon cc con_id [] ->
142 -- Trivial RHS, so augment envt, and ditch the binding
143 returnUs (triv_binds, new_env)
145 new_env = addOneToIdEnv env binder (StgConArg con_id)
147 other -> -- Non-trivial RHS, so don't augment envt
148 returnUs ([StgNonRec binder stg_rhs], env)
150 coreBindToStg env (Rec pairs)
151 = -- NB: *** WE DO NOT CHECK FOR TRIV_BINDS in REC BIND ****
154 (binders, rhss) = unzip pairs
156 mapUs (coreRhsToStg env) rhss `thenUs` \ stg_rhss ->
157 returnUs ([StgRec (binders `zip` stg_rhss)], env)
161 %************************************************************************
163 \subsection[coreToStg-rhss]{Converting right hand sides}
165 %************************************************************************
168 coreRhsToStg :: StgEnv -> CoreExpr -> UniqSM StgRhs
170 coreRhsToStg env core_rhs
171 = coreExprToStg env core_rhs `thenUs` \ stg_expr ->
173 let stg_rhs = case stg_expr of
174 StgLet (StgNonRec var1 rhs) (StgApp (StgVarArg var2) [] _)
175 | var1 == var2 -> rhs
176 -- This curious stuff is to unravel what a lambda turns into
177 -- We have to do it this way, rather than spot a lambda in the
178 -- incoming rhs. Why? Because trivial bindings might conceal
179 -- what the rhs is actually like.
181 StgCon con args _ -> StgRhsCon noCostCentre con args
183 other -> StgRhsClosure noCostCentre -- No cost centre (ToDo?)
186 Updatable -- Be pessimistic
194 %************************************************************************
196 \subsection[coreToStg-atoms{Converting atoms}
198 %************************************************************************
201 coreArgsToStg :: StgEnv -> [CoreArg] -> ([Type], [StgArg])
203 coreArgsToStg env [] = ([], [])
204 coreArgsToStg env (a:as)
206 TyArg t -> (t:trest, vrest)
207 VarArg v -> (trest, stgLookup env v : vrest)
208 LitArg l -> (trest, StgLitArg l : vrest)
210 (trest,vrest) = coreArgsToStg env as
214 %************************************************************************
216 \subsection[coreToStg-exprs]{Converting core expressions}
218 %************************************************************************
221 coreExprToStg :: StgEnv -> CoreExpr -> UniqSM StgExpr
223 coreExprToStg env (Lit lit)
224 = returnUs (StgApp (StgLitArg lit) [] bOGUS_LVs)
226 coreExprToStg env (Var var)
227 = returnUs (mk_app (stgLookup env var) [])
229 coreExprToStg env (Con con args)
231 (types, stg_atoms) = coreArgsToStg env args
233 returnUs (StgCon con stg_atoms bOGUS_LVs)
235 coreExprToStg env (Prim op args)
237 (types, stg_atoms) = coreArgsToStg env args
239 returnUs (StgPrim op stg_atoms bOGUS_LVs)
242 %************************************************************************
244 \subsubsection[coreToStg-lambdas]{Lambda abstractions}
246 %************************************************************************
249 coreExprToStg env expr@(Lam _ _)
251 (_, binders, body) = collectBinders expr
253 coreExprToStg env body `thenUs` \ stg_body ->
255 if null binders then -- it was all type/usage binders; tossed
258 newStgVar (coreExprType expr) `thenUs` \ var ->
260 (StgLet (StgNonRec var
261 (StgRhsClosure noCostCentre
264 ReEntrant -- binders is non-empty
267 (StgApp (StgVarArg var) [] bOGUS_LVs))
270 %************************************************************************
272 \subsubsection[coreToStg-applications]{Applications}
274 %************************************************************************
277 coreExprToStg env expr@(App _ _)
279 (fun,args) = collect_args expr []
280 (_, stg_args) = coreArgsToStg env args
282 -- Now deal with the function
284 (Var fun_id, _) -> -- A function Id, so do an StgApp; it's ok if
285 -- there are no arguments.
286 returnUs (mk_app (stgLookup env fun_id) stg_args)
288 (non_var_fun, []) -> -- No value args, so recurse into the function
289 coreExprToStg env non_var_fun
291 other -> -- A non-variable applied to things; better let-bind it.
292 newStgVar (coreExprType fun) `thenUs` \ fun_id ->
293 coreExprToStg env fun `thenUs` \ (stg_fun) ->
295 fun_rhs = StgRhsClosure noCostCentre -- No cost centre (ToDo?)
298 SingleEntry -- Only entered once
302 returnUs (StgLet (StgNonRec fun_id fun_rhs)
303 (StgApp (StgVarArg fun_id) stg_args bOGUS_LVs))
305 -- Collect arguments, discarding type/usage applications
306 collect_args (App e (TyArg _)) args = collect_args e args
307 collect_args (App fun arg) args = collect_args fun (arg:args)
308 collect_args (Coerce _ _ expr) args = collect_args expr args
309 collect_args fun args = (fun, args)
312 %************************************************************************
314 \subsubsection[coreToStg-cases]{Case expressions}
316 %************************************************************************
319 coreExprToStg env (Case discrim alts)
320 = coreExprToStg env discrim `thenUs` \ stg_discrim ->
321 alts_to_stg discrim alts `thenUs` \ stg_alts ->
322 getUnique `thenUs` \ uniq ->
331 discrim_ty = coreExprType discrim
332 (_, discrim_ty_args, _) = splitAlgTyConApp discrim_ty
334 alts_to_stg discrim (AlgAlts alts deflt)
335 = default_to_stg discrim deflt `thenUs` \ stg_deflt ->
336 mapUs boxed_alt_to_stg alts `thenUs` \ stg_alts ->
337 returnUs (StgAlgAlts discrim_ty stg_alts stg_deflt)
339 boxed_alt_to_stg (con, bs, rhs)
340 = coreExprToStg env rhs `thenUs` \ stg_rhs ->
341 returnUs (con, bs, [ True | b <- bs ]{-bogus use mask-}, stg_rhs)
343 alts_to_stg discrim (PrimAlts alts deflt)
344 = default_to_stg discrim deflt `thenUs` \ stg_deflt ->
345 mapUs unboxed_alt_to_stg alts `thenUs` \ stg_alts ->
346 returnUs (StgPrimAlts discrim_ty stg_alts stg_deflt)
348 unboxed_alt_to_stg (lit, rhs)
349 = coreExprToStg env rhs `thenUs` \ stg_rhs ->
350 returnUs (lit, stg_rhs)
352 default_to_stg discrim NoDefault
353 = returnUs StgNoDefault
355 default_to_stg discrim (BindDefault binder rhs)
356 = coreExprToStg env rhs `thenUs` \ stg_rhs ->
357 returnUs (StgBindDefault binder True{-used? no it is lying-} stg_rhs)
360 %************************************************************************
362 \subsubsection[coreToStg-let(rec)]{Let and letrec expressions}
364 %************************************************************************
367 coreExprToStg env (Let bind body)
368 = coreBindToStg env bind `thenUs` \ (stg_binds, new_env) ->
369 coreExprToStg new_env body `thenUs` \ stg_body ->
370 returnUs (mkStgLets stg_binds stg_body)
374 %************************************************************************
376 \subsubsection[coreToStg-scc]{SCC expressions}
378 %************************************************************************
380 Covert core @scc@ expression directly to STG @scc@ expression.
382 coreExprToStg env (SCC cc expr)
383 = coreExprToStg env expr `thenUs` \ stg_expr ->
384 returnUs (StgSCC (coreExprType expr) cc stg_expr)
388 coreExprToStg env (Coerce c ty expr) = coreExprToStg env expr
392 %************************************************************************
394 \subsection[coreToStg-misc]{Miscellaneous helping functions}
396 %************************************************************************
398 There's not anything interesting we can ASSERT about \tr{var} if it
399 isn't in the StgEnv. (WDP 94/06)
402 stgLookup :: StgEnv -> Id -> StgArg
403 stgLookup env var = case (lookupIdEnv env var) of
404 Nothing -> StgVarArg var
410 newStgVar :: Type -> UniqSM Id
412 = getUnique `thenUs` \ uniq ->
413 returnUs (mkSysLocal SLIT("stg") uniq ty noSrcLoc)
417 mkStgLets :: [StgBinding]
418 -> StgExpr -- body of let
421 mkStgLets binds body = foldr StgLet body binds
423 -- mk_app spots an StgCon in a function position,
424 -- and turns it into an StgCon. See notes with
425 -- getArgAmode in CgBindery.
426 mk_app (StgConArg con) args = StgCon con args bOGUS_LVs
427 mk_app other_fun args = StgApp other_fun args bOGUS_LVs