2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
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 CoreUtils ( coreExprType )
21 import SimplUtils ( findDefault )
22 import CostCentre ( noCCS )
23 import Id ( Id, mkUserLocal, idType,
24 externallyVisibleId, setIdUnique
26 import Name ( varOcc )
28 import Const ( Con(..), isWHNFCon, Literal(..) )
29 import PrimOp ( PrimOp(..) )
30 import Type ( isUnLiftedType, isUnboxedTupleType, Type )
31 import Unique ( Unique, Uniquable(..) )
32 import UniqSupply -- all of it, really
37 *************** OVERVIEW *********************
40 The business of this pass is to convert Core to Stg. On the way:
42 * We discard type lambdas and applications. In so doing we discard
43 "trivial" bindings such as
45 where t1, t2 are types
47 * We don't pin on correct arities any more, because they can be mucked up
48 by the lambda lifter. In particular, the lambda lifter can take a local
49 letrec-bound variable and make it a lambda argument, which shouldn't have
50 an arity. So SetStgVarInfo sets arities now.
52 * We do *not* pin on the correct free/live var info; that's done later.
53 Instead we use bOGUS_LVS and _FVS as a placeholder.
55 [Quite a bit of stuff that used to be here has moved
56 to tidyCorePgm (SimplCore.lhs) SLPJ Nov 96]
59 %************************************************************************
61 \subsection[coreToStg-programs]{Converting a core program and core bindings}
63 %************************************************************************
65 March 98: We keep a small environment to give all locally bound
66 Names new unique ids, since the code generator assumes that binders
67 are unique across a module. (Simplifier doesn't maintain this
68 invariant any longer.)
71 type StgEnv = IdEnv Id
74 No free/live variable information is pinned on in this pass; it's added
76 we use @bOGUS_LVs@ and @bOGUS_FVs@ as placeholders.
79 bOGUS_LVs :: StgLiveVars
80 bOGUS_LVs = panic "bOGUS_LVs" -- emptyUniqSet (used when pprTracing)
83 bOGUS_FVs = panic "bOGUS_FVs" -- [] (ditto)
87 topCoreBindsToStg :: UniqSupply -- name supply
88 -> [CoreBind] -- input
89 -> [StgBinding] -- output
91 topCoreBindsToStg us core_binds
92 = initUs us (coreBindsToStg emptyVarEnv core_binds)
94 coreBindsToStg :: StgEnv -> [CoreBind] -> UniqSM [StgBinding]
96 coreBindsToStg env [] = returnUs []
97 coreBindsToStg env (b:bs)
98 = coreBindToStg env b `thenUs` \ (new_b, new_env) ->
99 coreBindsToStg new_env bs `thenUs` \ new_bs ->
100 returnUs (new_b ++ new_bs)
103 %************************************************************************
105 \subsection[coreToStg-binds]{Converting bindings}
107 %************************************************************************
110 coreBindToStg :: StgEnv
112 -> UniqSM ([StgBinding], -- Empty or singleton
115 coreBindToStg env (NonRec binder rhs)
116 = coreRhsToStg env rhs `thenUs` \ stg_rhs ->
117 newLocalId env binder `thenUs` \ (new_env, new_binder) ->
118 returnUs ([StgNonRec new_binder stg_rhs], new_env)
120 coreBindToStg env (Rec pairs)
121 = newLocalIds env binders `thenUs` \ (env', binders') ->
122 mapUs (coreRhsToStg env') rhss `thenUs` \ stg_rhss ->
123 returnUs ([StgRec (binders' `zip` stg_rhss)], env')
125 (binders, rhss) = unzip pairs
129 %************************************************************************
131 \subsection[coreToStg-rhss]{Converting right hand sides}
133 %************************************************************************
136 coreRhsToStg :: StgEnv -> CoreExpr -> UniqSM StgRhs
138 coreRhsToStg env core_rhs
139 = coreExprToStg env core_rhs `thenUs` \ stg_expr ->
140 returnUs (exprToRhs stg_expr)
142 exprToRhs (StgLet (StgNonRec var1 rhs) (StgApp var2 []))
145 -- This curious stuff is to unravel what a lambda turns into
146 -- We have to do it this way, rather than spot a lambda in the
147 -- incoming rhs. Why? Because trivial bindings might conceal
148 -- what the rhs is actually like.
150 exprToRhs (StgCon (DataCon con) args _) = StgRhsCon noCCS con args
153 = StgRhsClosure noCCS -- No cost centre (ToDo?)
155 noSRT -- figure out later
157 Updatable -- Be pessimistic
164 %************************************************************************
166 \subsection[coreToStg-atoms{Converting atoms}
168 %************************************************************************
171 coreArgsToStg :: StgEnv -> [CoreArg]
172 -> UniqSM ([(Id,StgExpr)], [StgArg])
177 coreArgsToStg env (Type ty : as) -- Discard type arguments
178 = coreArgsToStg env as
180 coreArgsToStg env (a:as)
181 = coreArgToStg env a `thenUs` \ (bs1, a') ->
182 coreArgsToStg env as `thenUs` \ (bs2, as') ->
183 returnUs (bs1 ++ bs2, a' : as')
185 -- This is where we arrange that a non-trivial argument is let-bound
187 coreArgToStg :: StgEnv -> CoreArg -> UniqSM ([(Id,StgExpr)], StgArg)
190 = coreExprToStgFloat env arg `thenUs` \ (binds, arg') ->
191 case (binds, arg') of
192 ([], StgCon con [] _) | isWHNFCon con -> returnUs ([], StgConArg con)
193 ([], StgApp v []) -> returnUs ([], StgVarArg v)
195 -- A non-trivial argument: we must let (or case-bind)
196 -- We don't do the case part here... we leave that to mkStgLets
198 -- Further complication: if we're converting this binding into
199 -- a case, then try to avoid generating any case-of-case
200 -- expressions by pulling out the floats.
202 newStgVar ty `thenUs` \ v ->
204 then returnUs (binds ++ [(v,arg')], StgVarArg v)
205 else returnUs ([(v, mkStgLets binds arg')], StgVarArg v)
207 ty = coreExprType arg
212 %************************************************************************
214 \subsection[coreToStg-exprs]{Converting core expressions}
216 %************************************************************************
219 coreExprToStg :: StgEnv -> CoreExpr -> UniqSM StgExpr
221 coreExprToStg env (Var var)
222 = returnUs (StgApp (stgLookup env var) [])
226 %************************************************************************
228 \subsubsection[coreToStg-lambdas]{Lambda abstractions}
230 %************************************************************************
233 coreExprToStg env expr@(Lam _ _)
235 (binders, body) = collectBinders expr
236 id_binders = filter isId binders
238 newLocalIds env id_binders `thenUs` \ (env', binders') ->
239 coreExprToStg env' body `thenUs` \ stg_body ->
241 if null id_binders then -- it was all type/usage binders; tossed
246 -- if the body reduced to a lambda too...
247 (StgLet (StgNonRec var (StgRhsClosure cc bi srt fvs uf args body))
250 returnUs (StgLet (StgNonRec var
262 -- We must let-bind the lambda
263 newStgVar (coreExprType expr) `thenUs` \ var ->
265 (StgLet (StgNonRec var (StgRhsClosure noCCS
269 ReEntrant -- binders is non-empty
275 %************************************************************************
277 \subsubsection[coreToStg-let(rec)]{Let and letrec expressions}
279 %************************************************************************
282 coreExprToStg env (Let bind body)
283 = coreBindToStg env bind `thenUs` \ (stg_binds, new_env) ->
284 coreExprToStg new_env body `thenUs` \ stg_body ->
285 returnUs (foldr StgLet stg_body stg_binds)
289 %************************************************************************
291 \subsubsection[coreToStg-scc]{SCC expressions}
293 %************************************************************************
295 Covert core @scc@ expression directly to STG @scc@ expression.
297 coreExprToStg env (Note (SCC cc) expr)
298 = coreExprToStg env expr `thenUs` \ stg_expr ->
299 returnUs (StgSCC cc stg_expr)
303 coreExprToStg env (Note other_note expr) = coreExprToStg env expr
306 The rest are handled by coreExprStgFloat.
309 coreExprToStg env expr
310 = coreExprToStgFloat env expr `thenUs` \ (binds,stg_expr) ->
311 returnUs (mkStgLets binds stg_expr)
314 %************************************************************************
316 \subsubsection[coreToStg-applications]{Applications}
318 %************************************************************************
321 coreExprToStgFloat env expr@(App _ _)
323 (fun,args) = collect_args expr []
325 coreArgsToStg env args `thenUs` \ (binds, stg_args) ->
327 -- Now deal with the function
328 case (fun, stg_args) of
329 (Var fun_id, _) -> -- A function Id, so do an StgApp; it's ok if
330 -- there are no arguments.
332 StgApp (stgLookup env fun_id) stg_args)
334 (non_var_fun, []) -> -- No value args, so recurse into the function
336 coreExprToStg env non_var_fun `thenUs` \e ->
339 other -> -- A non-variable applied to things; better let-bind it.
340 newStgVar (coreExprType fun) `thenUs` \ fun_id ->
341 coreExprToStg env fun `thenUs` \ (stg_fun) ->
343 fun_rhs = StgRhsClosure noCCS -- No cost centre (ToDo?)
347 SingleEntry -- Only entered once
352 StgLet (StgNonRec fun_id fun_rhs) $
353 StgApp fun_id stg_args)
356 collect_args (App fun arg) args = collect_args fun (arg:args)
357 collect_args (Note (Coerce _ _) expr) args = collect_args expr args
358 collect_args (Note InlineCall expr) args = collect_args expr args
359 collect_args fun args = (fun, args)
362 %************************************************************************
364 \subsubsection[coreToStg-con]{Constructors}
366 %************************************************************************
369 coreExprToStgFloat env expr@(Con (PrimOp (CCallOp (Right _) a b c)) args)
370 = getUniqueUs `thenUs` \ u ->
371 coreArgsToStg env args `thenUs` \ (binds, stg_atoms) ->
372 let con' = PrimOp (CCallOp (Right u) a b c) in
373 returnUs (binds, StgCon con' stg_atoms (coreExprType expr))
375 coreExprToStgFloat env expr@(Con con args)
376 = coreArgsToStg env args `thenUs` \ (binds, stg_atoms) ->
377 returnUs (binds, StgCon con stg_atoms (coreExprType expr))
380 %************************************************************************
382 \subsubsection[coreToStg-cases]{Case expressions}
384 %************************************************************************
387 coreExprToStgFloat env expr@(Case scrut bndr alts)
388 = coreExprToStgFloat env scrut `thenUs` \ (binds, scrut') ->
389 newLocalId env bndr `thenUs` \ (env', bndr') ->
390 alts_to_stg env' (findDefault alts) `thenUs` \ alts' ->
391 returnUs (binds, mkStgCase scrut' bndr' alts')
393 scrut_ty = idType bndr
394 prim_case = isUnLiftedType scrut_ty && not (isUnboxedTupleType scrut_ty)
396 alts_to_stg env (alts, deflt)
398 = default_to_stg env deflt `thenUs` \ deflt' ->
399 mapUs (prim_alt_to_stg env) alts `thenUs` \ alts' ->
400 returnUs (StgPrimAlts scrut_ty alts' deflt')
403 = default_to_stg env deflt `thenUs` \ deflt' ->
404 mapUs (alg_alt_to_stg env) alts `thenUs` \ alts' ->
405 returnUs (StgAlgAlts scrut_ty alts' deflt')
407 alg_alt_to_stg env (DataCon con, bs, rhs)
408 = coreExprToStg env rhs `thenUs` \ stg_rhs ->
409 returnUs (con, bs, [ True | b <- bs ]{-bogus use mask-}, stg_rhs)
411 prim_alt_to_stg env (Literal lit, args, rhs)
412 = ASSERT( null args )
413 coreExprToStg env rhs `thenUs` \ stg_rhs ->
414 returnUs (lit, stg_rhs)
416 default_to_stg env Nothing
417 = returnUs StgNoDefault
419 default_to_stg env (Just rhs)
420 = coreExprToStg env rhs `thenUs` \ stg_rhs ->
421 returnUs (StgBindDefault stg_rhs)
422 -- The binder is used for prim cases and not otherwise
423 -- (hack for old code gen)
427 coreExprToStgFloat env expr
428 = coreExprToStg env expr `thenUs` \stg_expr ->
429 returnUs ([], stg_expr)
432 %************************************************************************
434 \subsection[coreToStg-misc]{Miscellaneous helping functions}
436 %************************************************************************
438 There's not anything interesting we can ASSERT about \tr{var} if it
439 isn't in the StgEnv. (WDP 94/06)
442 stgLookup :: StgEnv -> Id -> Id
443 stgLookup env var = case (lookupVarEnv env var) of
450 newStgVar :: Type -> UniqSM Id
452 = getUniqueUs `thenUs` \ uniq ->
453 returnUs (mkUserLocal (varOcc SLIT("stg")) uniq ty)
458 | externallyVisibleId id
462 = -- Local binder, give it a new unique Id.
463 getUniqueUs `thenUs` \ uniq ->
465 id' = setIdUnique id uniq
466 new_env = extendVarEnv env id id'
468 returnUs (new_env, id')
470 newLocalIds :: StgEnv -> [Id] -> UniqSM (StgEnv, [Id])
473 newLocalIds env (b:bs)
474 = newLocalId env b `thenUs` \ (env', b') ->
475 newLocalIds env' bs `thenUs` \ (env'', bs') ->
476 returnUs (env'', b':bs')
481 mkStgLets :: [(Id,StgExpr)] -> StgExpr -> StgExpr
482 mkStgLets binds body = foldr mkStgLet body binds
484 mkStgLet (bndr, rhs) body
485 | isUnboxedTupleType bndr_ty
486 = panic "mkStgLets: unboxed tuple"
487 | isUnLiftedType bndr_ty
488 = mkStgCase rhs bndr (StgPrimAlts bndr_ty [] (StgBindDefault body))
491 = StgLet (StgNonRec bndr (exprToRhs rhs)) body
493 bndr_ty = idType bndr
495 mkStgCase (StgLet bind expr) bndr alts
496 = StgLet bind (mkStgCase expr bndr alts)
497 mkStgCase scrut bndr alts
498 = StgCase scrut bOGUS_LVs bOGUS_LVs bndr noSRT alts