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,
28 nullIdEnv, addOneToIdEnv, lookupIdEnv, growIdEnvList,
29 SYN_IE(IdEnv), GenId{-instance NamedThing-}, SYN_IE(Id)
31 import Literal ( mkMachInt, Literal(..) )
32 import PrelVals ( unpackCStringId, unpackCString2Id,
33 integerZeroId, integerPlusOneId,
34 integerPlusTwoId, integerMinusOneId
36 import PrimOp ( PrimOp(..) )
37 import SpecUtils ( mkSpecialisedCon )
38 import SrcLoc ( noSrcLoc )
39 import TyCon ( TyCon{-instance Uniquable-} )
40 import Type ( getAppDataTyConExpandingDicts, SYN_IE(Type) )
41 import TysWiredIn ( stringTy )
42 import Unique ( integerTyConKey, ratioTyConKey, Unique{-instance Eq-} )
43 import UniqSupply -- all of it, really
44 import Util ( zipLazy, panic, assertPanic{-, pprTrace ToDo:rm-} )
46 isLeakFreeType x y = False -- safe option; ToDo
50 *************** OVERVIEW *********************
53 The business of this pass is to convert Core to Stg. On the way:
55 * We discard type lambdas and applications. In so doing we discard
56 "trivial" bindings such as
58 where t1, t2 are types
60 * We don't pin on correct arities any more, because they can be mucked up
61 by the lambda lifter. In particular, the lambda lifter can take a local
62 letrec-bound variable and make it a lambda argument, which shouldn't have
63 an arity. So SetStgVarInfo sets arities now.
65 * We do *not* pin on the correct free/live var info; that's done later.
66 Instead we use bOGUS_LVS and _FVS as a placeholder.
68 [Quite a bit of stuff that used to be here has moved
69 to tidyCorePgm (SimplCore.lhs) SLPJ Nov 96]
72 %************************************************************************
74 \subsection[coreToStg-programs]{Converting a core program and core bindings}
76 %************************************************************************
78 Because we're going to come across ``boring'' bindings like
79 \tr{let x = /\ tyvars -> y in ...}, we want to keep a small
80 environment, so we can just replace all occurrences of \tr{x}
84 type StgEnv = IdEnv StgArg
87 No free/live variable information is pinned on in this pass; it's added
89 we use @bOGUS_LVs@ and @bOGUS_FVs@ as placeholders.
92 bOGUS_LVs :: StgLiveVars
93 bOGUS_LVs = panic "bOGUS_LVs" -- emptyUniqSet (used when pprTracing)
96 bOGUS_FVs = panic "bOGUS_FVs" -- [] (ditto)
100 topCoreBindsToStg :: UniqSupply -- name supply
101 -> [CoreBinding] -- input
102 -> [StgBinding] -- output
104 topCoreBindsToStg us core_binds
105 = initUs us (coreBindsToStg nullIdEnv core_binds)
107 coreBindsToStg :: StgEnv -> [CoreBinding] -> UniqSM [StgBinding]
109 coreBindsToStg env [] = returnUs []
110 coreBindsToStg env (b:bs)
111 = coreBindToStg env b `thenUs` \ (new_b, new_env) ->
112 coreBindsToStg new_env bs `thenUs` \ new_bs ->
113 returnUs (new_b ++ new_bs)
116 %************************************************************************
118 \subsection[coreToStg-binds]{Converting bindings}
120 %************************************************************************
123 coreBindToStg :: StgEnv
125 -> UniqSM ([StgBinding], -- Empty or singleton
128 coreBindToStg env (NonRec binder rhs)
129 = coreRhsToStg env rhs `thenUs` \ stg_rhs ->
131 -- Binds to return if RHS is trivial
132 triv_binds | externallyVisibleId binder = [StgNonRec binder stg_rhs] -- Retain it
133 | otherwise = [] -- Discard it
136 StgRhsClosure cc bi fvs upd [] (StgApp atom [] lvs) ->
137 -- Trivial RHS, so augment envt, and ditch the binding
138 returnUs (triv_binds, new_env)
140 new_env = addOneToIdEnv env binder atom
142 StgRhsCon cc con_id [] ->
143 -- Trivial RHS, so augment envt, and ditch the binding
144 returnUs (triv_binds, new_env)
146 new_env = addOneToIdEnv env binder (StgConArg con_id)
148 other -> -- Non-trivial RHS, so don't augment envt
149 returnUs ([StgNonRec binder stg_rhs], env)
151 coreBindToStg env (Rec pairs)
152 = -- NB: *** WE DO NOT CHECK FOR TRIV_BINDS in REC BIND ****
155 (binders, rhss) = unzip pairs
157 mapUs (coreRhsToStg env) rhss `thenUs` \ stg_rhss ->
158 returnUs ([StgRec (binders `zip` stg_rhss)], env)
162 %************************************************************************
164 \subsection[coreToStg-rhss]{Converting right hand sides}
166 %************************************************************************
169 coreRhsToStg :: StgEnv -> CoreExpr -> UniqSM StgRhs
171 coreRhsToStg env core_rhs
172 = coreExprToStg env core_rhs `thenUs` \ stg_expr ->
174 let stg_rhs = case stg_expr of
175 StgLet (StgNonRec var1 rhs) (StgApp (StgVarArg var2) [] _)
176 | var1 == var2 -> rhs
177 -- This curious stuff is to unravel what a lambda turns into
178 -- We have to do it this way, rather than spot a lambda in the
179 -- incoming rhs. Why? Because trivial bindings might conceal
180 -- what the rhs is actually like.
182 StgCon con args _ -> StgRhsCon noCostCentre con args
184 other -> StgRhsClosure noCostCentre -- No cost centre (ToDo?)
187 Updatable -- Be pessimistic
195 %************************************************************************
197 \subsection[coreToStg-atoms{Converting atoms}
199 %************************************************************************
202 coreArgsToStg :: StgEnv -> [CoreArg] -> ([Type], [StgArg])
204 coreArgsToStg env [] = ([], [])
205 coreArgsToStg env (a:as)
207 TyArg t -> (t:trest, vrest)
208 UsageArg u -> (trest, vrest)
209 VarArg v -> (trest, stgLookup env v : vrest)
210 LitArg l -> (trest, StgLitArg l : vrest)
212 (trest,vrest) = coreArgsToStg env as
216 %************************************************************************
218 \subsection[coreToStg-exprs]{Converting core expressions}
220 %************************************************************************
223 coreExprToStg :: StgEnv -> CoreExpr -> UniqSM StgExpr
225 coreExprToStg env (Lit lit)
226 = returnUs (StgApp (StgLitArg lit) [] bOGUS_LVs)
228 coreExprToStg env (Var var)
229 = returnUs (mk_app (stgLookup env var) [])
231 coreExprToStg env (Con con args)
233 (types, stg_atoms) = coreArgsToStg env args
234 spec_con = mkSpecialisedCon con types
236 returnUs (StgCon spec_con stg_atoms bOGUS_LVs)
238 coreExprToStg env (Prim op args)
240 (types, stg_atoms) = coreArgsToStg env args
242 returnUs (StgPrim op stg_atoms bOGUS_LVs)
245 %************************************************************************
247 \subsubsection[coreToStg-lambdas]{Lambda abstractions}
249 %************************************************************************
252 coreExprToStg env expr@(Lam _ _)
254 (_,_, binders, body) = collectBinders expr
256 coreExprToStg env body `thenUs` \ stg_body ->
258 if null binders then -- it was all type/usage binders; tossed
261 newStgVar (coreExprType expr) `thenUs` \ var ->
263 (StgLet (StgNonRec var
264 (StgRhsClosure noCostCentre
267 ReEntrant -- binders is non-empty
270 (StgApp (StgVarArg var) [] bOGUS_LVs))
273 %************************************************************************
275 \subsubsection[coreToStg-applications]{Applications}
277 %************************************************************************
280 coreExprToStg env expr@(App _ _)
282 (fun,args) = collect_args expr []
283 (_, stg_args) = coreArgsToStg env args
285 -- Now deal with the function
287 (Var fun_id, _) -> -- A function Id, so do an StgApp; it's ok if
288 -- there are no arguments.
289 returnUs (mk_app (stgLookup env fun_id) stg_args)
291 (non_var_fun, []) -> -- No value args, so recurse into the function
292 coreExprToStg env non_var_fun
294 other -> -- A non-variable applied to things; better let-bind it.
295 newStgVar (coreExprType fun) `thenUs` \ fun_id ->
296 coreExprToStg env fun `thenUs` \ (stg_fun) ->
298 fun_rhs = StgRhsClosure noCostCentre -- No cost centre (ToDo?)
301 SingleEntry -- Only entered once
305 returnUs (StgLet (StgNonRec fun_id fun_rhs)
306 (StgApp (StgVarArg fun_id) stg_args bOGUS_LVs))
308 -- Collect arguments, discarding type/usage applications
309 collect_args (App e (TyArg _)) args = collect_args e args
310 collect_args (App e (UsageArg _)) args = collect_args e args
311 collect_args (App fun arg) args = collect_args fun (arg:args)
312 collect_args fun args = (fun, args)
315 %************************************************************************
317 \subsubsection[coreToStg-cases]{Case expressions}
319 %************************************************************************
322 coreExprToStg env (Case discrim alts)
323 = coreExprToStg env discrim `thenUs` \ stg_discrim ->
324 alts_to_stg discrim alts `thenUs` \ stg_alts ->
325 getUnique `thenUs` \ uniq ->
334 discrim_ty = coreExprType discrim
335 (_, discrim_ty_args, _) = getAppDataTyConExpandingDicts discrim_ty
337 alts_to_stg discrim (AlgAlts alts deflt)
338 = default_to_stg discrim deflt `thenUs` \ stg_deflt ->
339 mapUs boxed_alt_to_stg alts `thenUs` \ stg_alts ->
340 returnUs (StgAlgAlts discrim_ty stg_alts stg_deflt)
342 boxed_alt_to_stg (con, bs, rhs)
343 = coreExprToStg env rhs `thenUs` \ stg_rhs ->
344 returnUs (spec_con, bs, [ True | b <- bs ]{-bogus use mask-}, stg_rhs)
346 spec_con = mkSpecialisedCon con discrim_ty_args
348 alts_to_stg discrim (PrimAlts alts deflt)
349 = default_to_stg discrim deflt `thenUs` \ stg_deflt ->
350 mapUs unboxed_alt_to_stg alts `thenUs` \ stg_alts ->
351 returnUs (StgPrimAlts discrim_ty stg_alts stg_deflt)
353 unboxed_alt_to_stg (lit, rhs)
354 = coreExprToStg env rhs `thenUs` \ stg_rhs ->
355 returnUs (lit, stg_rhs)
357 default_to_stg discrim NoDefault
358 = returnUs StgNoDefault
360 default_to_stg discrim (BindDefault binder rhs)
361 = coreExprToStg env rhs `thenUs` \ stg_rhs ->
362 returnUs (StgBindDefault binder True{-used? no it is lying-} stg_rhs)
365 %************************************************************************
367 \subsubsection[coreToStg-let(rec)]{Let and letrec expressions}
369 %************************************************************************
372 coreExprToStg env (Let bind body)
373 = coreBindToStg env bind `thenUs` \ (stg_binds, new_env) ->
374 coreExprToStg new_env body `thenUs` \ stg_body ->
375 returnUs (mkStgLets stg_binds stg_body)
379 %************************************************************************
381 \subsubsection[coreToStg-scc]{SCC expressions}
383 %************************************************************************
385 Covert core @scc@ expression directly to STG @scc@ expression.
387 coreExprToStg env (SCC cc expr)
388 = coreExprToStg env expr `thenUs` \ stg_expr ->
389 returnUs (StgSCC (coreExprType expr) cc stg_expr)
393 coreExprToStg env (Coerce c ty expr) = coreExprToStg env expr
397 %************************************************************************
399 \subsection[coreToStg-misc]{Miscellaneous helping functions}
401 %************************************************************************
403 There's not anything interesting we can ASSERT about \tr{var} if it
404 isn't in the StgEnv. (WDP 94/06)
407 stgLookup :: StgEnv -> Id -> StgArg
408 stgLookup env var = case (lookupIdEnv env var) of
409 Nothing -> StgVarArg var
415 newStgVar :: Type -> UniqSM Id
417 = getUnique `thenUs` \ uniq ->
418 returnUs (mkSysLocal SLIT("stg") uniq ty noSrcLoc)
422 mkStgLets :: [StgBinding]
423 -> StgExpr -- body of let
426 mkStgLets binds body = foldr StgLet body binds
428 -- mk_app spots an StgCon in a function position,
429 -- and turns it into an StgCon. See notes with
430 -- getArgAmode in CgBindery.
431 mk_app (StgConArg con) args = StgCon con args bOGUS_LVs
432 mk_app other_fun args = StgApp other_fun args bOGUS_LVs