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.
14 #include "HsVersions.h"
16 module CoreToStg ( topCoreBindsToStg ) where
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,
27 nullIdEnv, addOneToIdEnv, lookupIdEnv,
28 IdEnv(..), GenId{-instance NamedThing-}
30 import Literal ( mkMachInt, Literal(..) )
31 import Name ( isExported )
32 import PrelVals ( unpackCStringId, unpackCString2Id,
33 integerZeroId, integerPlusOneId,
34 integerPlusTwoId, integerMinusOneId
36 import PrimOp ( PrimOp(..) )
37 import SpecUtils ( mkSpecialisedCon )
38 import SrcLoc ( mkUnknownSrcLoc )
39 import Type ( getAppDataTyConExpandingDicts )
40 import TysWiredIn ( stringTy, integerTy, rationalTy, ratioDataCon )
41 import UniqSupply -- all of it, really
44 isLeakFreeType x y = False -- safe option; ToDo
48 *************** OVERVIEW *********************
51 The business of this pass is to convert Core to Stg. On the way:
53 * We discard type lambdas and applications. In so doing we discard
54 "trivial" bindings such as
56 where t1, t2 are types
58 * We make the representation of NoRep literals explicit, and
59 float their bindings to the top level
61 * We do *not* pin on the correct free/live var info; that's done later.
62 Instead we use bOGUS_LVS and _FVS as a placeholder.
64 * We convert case x of {...; x' -> ...x'...}
66 case x of {...; _ -> ...x... }
68 See notes in SimplCase.lhs, near simplDefault for the reasoning here.
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 = case (initUs us (binds_to_stg nullIdEnv core_binds)) of
107 binds_to_stg :: StgEnv -> [CoreBinding] -> UniqSM [StgBinding]
109 binds_to_stg env [] = returnUs []
110 binds_to_stg env (b:bs)
111 = do_top_bind env b `thenUs` \ (new_b, new_env, float_binds) ->
112 binds_to_stg new_env bs `thenUs` \ new_bs ->
113 returnUs (bagToList float_binds ++ -- Literals
117 do_top_bind env bind@(Rec pairs)
118 = coreBindToStg env bind
120 do_top_bind env bind@(NonRec var rhs)
121 = coreBindToStg env bind `thenUs` \ (stg_binds, new_env, float_binds) ->
124 ppr_blah xs = ppInterleave ppComma (map pp_x xs)
125 pp_x (u,x) = ppBesides [pprUnique u, ppStr ": ", ppr PprDebug x]
127 pprTrace "do_top_bind:" (ppAbove (ppr PprDebug stg_binds) (ppr_blah (ufmToList new_env))) $
130 [StgNonRec var (StgRhsClosure cc bi fvs u [] rhs_body)] ->
131 -- Mega-special case; there's still a binding there
132 -- no fvs (of course), *no args*, "let" rhs
134 (extra_float_binds, rhs_body') = seek_liftable [] rhs_body
136 returnUs (extra_float_binds ++
137 [StgNonRec var (StgRhsClosure cc bi fvs u [] rhs_body')],
141 other -> returnUs (stg_binds, new_env, float_binds)
144 -- HACK: look for very simple, obviously-liftable bindings
145 -- that can come up to the top level; those that couldn't
146 -- 'cause they were big-lambda constrained in the Core world.
148 seek_liftable :: [StgBinding] -- accumulator...
149 -> StgExpr -- look for top-lev liftables
150 -> ([StgBinding], StgExpr) -- result
152 seek_liftable acc expr@(StgLet inner_bind body)
153 | is_liftable inner_bind
154 = seek_liftable (inner_bind : acc) body
156 seek_liftable acc other_expr = (reverse acc, other_expr) -- Finished
159 is_liftable (StgNonRec binder (StgRhsClosure _ _ _ _ args body))
160 = not (null args) -- it's manifestly a function...
161 || isLeakFreeType [] (idType binder)
163 -- ToDo: use a decent manifestlyWHNF function for STG?
165 is_whnf (StgCon _ _ _) = True
166 is_whnf (StgApp (StgVarArg v) _ _) = isBottomingId v
167 is_whnf other = False
169 is_liftable (StgRec [(_, StgRhsClosure _ _ _ _ args body)])
170 = not (null args) -- it's manifestly a (recursive) function...
172 is_liftable anything_else = False
175 %************************************************************************
177 \subsection[coreToStg-binds]{Converting bindings}
179 %************************************************************************
182 coreBindToStg :: StgEnv
184 -> UniqSM ([StgBinding], -- Empty or singleton
186 Bag StgBinding) -- Floats
188 coreBindToStg env (NonRec binder rhs)
189 = coreRhsToStg env rhs `thenUs` \ (stg_rhs, rhs_binds) ->
192 -- Binds to return if RHS is trivial
193 triv_binds = if isExported binder then
194 [StgNonRec binder stg_rhs] -- Retain it
199 StgRhsClosure cc bi fvs upd [] (StgApp atom [] lvs) ->
200 -- Trivial RHS, so augment envt, and ditch the binding
201 returnUs (triv_binds, new_env, rhs_binds)
203 new_env = addOneToIdEnv env binder atom
205 StgRhsCon cc con_id [] ->
206 -- Trivial RHS, so augment envt, and ditch the binding
207 returnUs (triv_binds, new_env, rhs_binds)
209 new_env = addOneToIdEnv env binder (StgVarArg con_id)
211 other -> -- Non-trivial RHS, so don't augment envt
212 returnUs ([StgNonRec binder stg_rhs], env, rhs_binds)
214 coreBindToStg env (Rec pairs)
215 = -- NB: *** WE DO NOT CHECK FOR TRIV_BINDS in REC BIND ****
218 (binders, rhss) = unzip pairs
220 mapAndUnzipUs (coreRhsToStg env) rhss `thenUs` \ (stg_rhss, rhs_binds) ->
221 returnUs ([StgRec (binders `zip` stg_rhss)], env, unionManyBags rhs_binds)
225 %************************************************************************
227 \subsection[coreToStg-rhss]{Converting right hand sides}
229 %************************************************************************
232 coreRhsToStg :: StgEnv -> CoreExpr -> UniqSM (StgRhs, Bag StgBinding)
234 coreRhsToStg env core_rhs
235 = coreExprToStg env core_rhs `thenUs` \ (stg_expr, stg_binds) ->
237 let stg_rhs = case stg_expr of
238 StgLet (StgNonRec var1 rhs) (StgApp (StgVarArg var2) [] _)
239 | var1 == var2 -> rhs
240 -- This curious stuff is to unravel what a lambda turns into
241 -- We have to do it this way, rather than spot a lambda in the
244 StgCon con args _ -> StgRhsCon noCostCentre con args
246 other -> StgRhsClosure noCostCentre -- No cost centre (ToDo?)
249 Updatable -- Be pessimistic
253 returnUs (stg_rhs, stg_binds)
257 %************************************************************************
259 \subsection[coreToStg-lits]{Converting literals}
261 %************************************************************************
263 Literals: the NoRep kind need to be de-no-rep'd.
264 We always replace them with a simple variable, and float a suitable
265 binding out to the top level.
267 If an Integer is small enough (Haskell implementations must support
268 Ints in the range $[-2^29+1, 2^29-1]$), wrap it up in @int2Integer@;
269 otherwise, wrap with @litString2Integer@.
272 tARGET_MIN_INT, tARGET_MAX_INT :: Integer
273 tARGET_MIN_INT = -536870912
274 tARGET_MAX_INT = 536870912
276 litToStgArg :: Literal -> UniqSM (StgArg, Bag StgBinding)
278 litToStgArg (NoRepStr s)
279 = newStgVar stringTy `thenUs` \ var ->
281 rhs = StgRhsClosure noCostCentre -- No cost centre (ToDo?)
284 Updatable -- WAS: ReEntrant (see note below)
288 -- We used not to update strings, so that they wouldn't clog up the heap,
289 -- but instead be unpacked each time. But on some programs that costs a lot
290 -- [eg hpg], so now we update them.
292 val = if (any is_NUL (_UNPK_ s)) then -- must cater for NULs in literal string
293 StgApp (StgVarArg unpackCString2Id)
294 [StgLitArg (MachStr s),
295 StgLitArg (mkMachInt (toInteger (_LENGTH_ s)))]
298 StgApp (StgVarArg unpackCStringId)
299 [StgLitArg (MachStr s)]
302 returnUs (StgVarArg var, unitBag (StgNonRec var rhs))
306 litToStgArg (NoRepInteger i)
307 -- extremely convenient to look out for a few very common
309 | i == 0 = returnUs (StgVarArg integerZeroId, emptyBag)
310 | i == 1 = returnUs (StgVarArg integerPlusOneId, emptyBag)
311 | i == 2 = returnUs (StgVarArg integerPlusTwoId, emptyBag)
312 | i == (-1) = returnUs (StgVarArg integerMinusOneId, emptyBag)
315 = newStgVar integerTy `thenUs` \ var ->
317 rhs = StgRhsClosure noCostCentre -- No cost centre (ToDo?)
320 Updatable -- Update an integer
325 | i > tARGET_MIN_INT && i < tARGET_MAX_INT
326 = -- Start from an Int
327 StgPrim Int2IntegerOp [StgLitArg (mkMachInt i)] bOGUS_LVs
330 = -- Start from a string
331 StgPrim Addr2IntegerOp [StgLitArg (MachStr (_PK_ (show i)))] bOGUS_LVs
333 returnUs (StgVarArg var, unitBag (StgNonRec var rhs))
335 litToStgArg (NoRepRational r)
336 = litToStgArg (NoRepInteger (numerator r)) `thenUs` \ (num_atom, binds1) ->
337 litToStgArg (NoRepInteger (denominator r)) `thenUs` \ (denom_atom, binds2) ->
338 newStgVar rationalTy `thenUs` \ var ->
340 rhs = StgRhsCon noCostCentre -- No cost centre (ToDo?)
341 ratioDataCon -- Constructor
342 [num_atom, denom_atom]
344 returnUs (StgVarArg var, binds1 `unionBags`
346 unitBag (StgNonRec var rhs))
348 litToStgArg other_lit = returnUs (StgLitArg other_lit, emptyBag)
352 %************************************************************************
354 \subsection[coreToStg-atoms{Converting atoms}
356 %************************************************************************
359 coreArgsToStg :: StgEnv -> [CoreArg] -> UniqSM ([Type], [StgArg], Bag StgBinding)
361 coreArgsToStg env [] = returnUs ([], [], emptyBag)
362 coreArgsToStg env (a:as)
363 = coreArgsToStg env as `thenUs` \ (tys, args, binds) ->
364 do_arg a tys args binds
366 do_arg a trest vrest binds
368 TyArg t -> returnUs (t:trest, vrest, binds)
369 UsageArg u -> returnUs (trest, vrest, binds)
370 VarArg v -> returnUs (trest, stgLookup env v : vrest, binds)
371 LitArg i -> litToStgArg i `thenUs` \ (v, bs) ->
372 returnUs (trest, v:vrest, bs `unionBags` binds)
375 There's not anything interesting we can ASSERT about \tr{var} if it
376 isn't in the StgEnv. (WDP 94/06)
378 stgLookup :: StgEnv -> Id -> StgArg
380 stgLookup env var = case (lookupIdEnv env var) of
381 Nothing -> StgVarArg var
385 %************************************************************************
387 \subsection[coreToStg-exprs]{Converting core expressions}
389 %************************************************************************
392 coreExprToStg :: StgEnv
394 -> UniqSM (StgExpr, -- Result
395 Bag StgBinding) -- Float these to top level
399 coreExprToStg env (Lit lit)
400 = litToStgArg lit `thenUs` \ (atom, binds) ->
401 returnUs (StgApp atom [] bOGUS_LVs, binds)
403 coreExprToStg env (Var var)
404 = returnUs (StgApp (stgLookup env var) [] bOGUS_LVs, emptyBag)
406 coreExprToStg env (Con con args)
407 = coreArgsToStg env args `thenUs` \ (types, stg_atoms, stg_binds) ->
409 spec_con = mkSpecialisedCon con types
411 returnUs (StgCon spec_con stg_atoms bOGUS_LVs, stg_binds)
413 coreExprToStg env (Prim op args)
414 = coreArgsToStg env args `thenUs` \ (_, stg_atoms, stg_binds) ->
415 returnUs (StgPrim op stg_atoms bOGUS_LVs, stg_binds)
418 %************************************************************************
420 \subsubsection[coreToStg-lambdas]{Lambda abstractions}
422 %************************************************************************
425 coreExprToStg env expr@(Lam _ _)
427 (_,_, binders, body) = collectBinders expr
429 coreExprToStg env body `thenUs` \ stuff@(stg_body, binds) ->
431 if null binders then -- it was all type/usage binders; tossed
434 newStgVar (coreExprType expr) `thenUs` \ var ->
436 (StgLet (StgNonRec var (StgRhsClosure noCostCentre
439 ReEntrant -- binders is non-empty
442 (StgApp (StgVarArg var) [] bOGUS_LVs),
446 %************************************************************************
448 \subsubsection[coreToStg-applications]{Applications}
450 %************************************************************************
453 coreExprToStg env expr@(App _ _)
455 (fun, _, _, args) = collectArgs expr
457 -- Deal with the arguments
458 coreArgsToStg env args `thenUs` \ (_, stg_args, arg_binds) ->
460 -- Now deal with the function
462 Var fun_id -> returnUs (StgApp (stgLookup env fun_id) stg_args bOGUS_LVs, arg_binds)
464 other -> -- A non-variable applied to things; better let-bind it.
465 newStgVar (coreExprType fun) `thenUs` \ fun_id ->
466 coreExprToStg env fun `thenUs` \ (stg_fun, fun_binds) ->
468 fun_rhs = StgRhsClosure noCostCentre -- No cost centre (ToDo?)
471 SingleEntry -- Only entered once
475 returnUs (StgLet (StgNonRec fun_id fun_rhs)
476 (StgApp (StgVarArg fun_id) stg_args bOGUS_LVs),
477 arg_binds `unionBags` fun_binds)
480 %************************************************************************
482 \subsubsection[coreToStg-cases]{Case expressions}
484 %************************************************************************
486 At this point, we *mangle* cases involving fork# and par# in the
487 discriminant. The original templates for these primops (see
488 @PrelVals.lhs@) constructed case expressions with boolean results
489 solely to fool the strictness analyzer, the simplifier, and anyone
490 else who might want to fool with the evaluation order. Now, we
491 believe that once the translation to STG code is performed, our
492 evaluation order is safe. Therefore, we convert expressions of the
506 coreExprToStg env (Case discrim@(Prim op _) alts)
508 = getUnique `thenUs` \ uniq ->
509 coreExprToStg env discrim `thenUs` \ (stg_discrim, discrim_binds) ->
510 alts_to_stg alts `thenUs` \ (stg_alts, alts_binds) ->
517 discrim_binds `unionBags` alts_binds
520 funnyParallelOp SeqOp = True
521 funnyParallelOp ParOp = True
522 funnyParallelOp ForkOp = True
523 funnyParallelOp _ = False
525 discrim_ty = coreExprType discrim
527 alts_to_stg (PrimAlts _ (BindDefault binder rhs))
528 = coreExprToStg env rhs `thenUs` \ (stg_rhs, rhs_binds) ->
530 stg_deflt = StgBindDefault binder False stg_rhs
532 returnUs (StgPrimAlts discrim_ty [] stg_deflt, rhs_binds)
534 -- OK, back to real life...
536 coreExprToStg env (Case discrim alts)
537 = coreExprToStg env discrim `thenUs` \ (stg_discrim, discrim_binds) ->
538 alts_to_stg discrim alts `thenUs` \ (stg_alts, alts_binds) ->
539 getUnique `thenUs` \ uniq ->
546 discrim_binds `unionBags` alts_binds
549 discrim_ty = coreExprType discrim
550 (_, discrim_ty_args, _) = getAppDataTyConExpandingDicts discrim_ty
552 alts_to_stg discrim (AlgAlts alts deflt)
553 = default_to_stg discrim deflt `thenUs` \ (stg_deflt, deflt_binds) ->
554 mapAndUnzipUs boxed_alt_to_stg alts `thenUs` \ (stg_alts, alts_binds) ->
555 returnUs (StgAlgAlts discrim_ty stg_alts stg_deflt,
556 deflt_binds `unionBags` unionManyBags alts_binds)
558 boxed_alt_to_stg (con, bs, rhs)
559 = coreExprToStg env rhs `thenUs` \ (stg_rhs, rhs_binds) ->
560 returnUs ((spec_con, bs, [ True | b <- bs ]{-bogus use mask-}, stg_rhs),
563 spec_con = mkSpecialisedCon con discrim_ty_args
565 alts_to_stg discrim (PrimAlts alts deflt)
566 = default_to_stg discrim deflt `thenUs` \ (stg_deflt,deflt_binds) ->
567 mapAndUnzipUs unboxed_alt_to_stg alts `thenUs` \ (stg_alts, alts_binds) ->
568 returnUs (StgPrimAlts discrim_ty stg_alts stg_deflt,
569 deflt_binds `unionBags` unionManyBags alts_binds)
571 unboxed_alt_to_stg (lit, rhs)
572 = coreExprToStg env rhs `thenUs` \ (stg_rhs, rhs_binds) ->
573 returnUs ((lit, stg_rhs), rhs_binds)
575 default_to_stg discrim NoDefault
576 = returnUs (StgNoDefault, emptyBag)
578 default_to_stg discrim (BindDefault binder rhs)
579 = coreExprToStg new_env rhs `thenUs` \ (stg_rhs, rhs_binds) ->
580 returnUs (StgBindDefault binder True{-used? no it is lying-} stg_rhs,
584 -- We convert case x of {...; x' -> ...x'...}
586 -- case x of {...; _ -> ...x... }
588 -- See notes in SimplCase.lhs, near simplDefault for the reasoning.
589 -- It's quite easily done: simply extend the environment to bind the
590 -- default binder to the scrutinee.
592 new_env = case discrim of
593 Var v -> addOneToIdEnv env binder (stgLookup env v)
597 %************************************************************************
599 \subsubsection[coreToStg-let(rec)]{Let and letrec expressions}
601 %************************************************************************
604 coreExprToStg env (Let bind body)
605 = coreBindToStg env bind `thenUs` \ (stg_binds, new_env, float_binds1) ->
606 coreExprToStg new_env body `thenUs` \ (stg_body, float_binds2) ->
607 returnUs (mkStgLets stg_binds stg_body, float_binds1 `unionBags` float_binds2)
611 %************************************************************************
613 \subsubsection[coreToStg-scc]{SCC expressions}
615 %************************************************************************
617 Covert core @scc@ expression directly to STG @scc@ expression.
619 coreExprToStg env (SCC cc expr)
620 = coreExprToStg env expr `thenUs` \ (stg_expr, binds) ->
621 returnUs (StgSCC (coreExprType expr) cc stg_expr, binds)
625 coreExprToStg env (Coerce c ty expr)
626 = coreExprToStg env expr -- `thenUs` \ (stg_expr, binds) ->
627 -- returnUs (StgSCC (coreExprType expr) cc stg_expr, binds)
631 %************************************************************************
633 \subsection[coreToStg-misc]{Miscellaneous helping functions}
635 %************************************************************************
641 newStgVar :: Type -> UniqSM Id
643 = getUnique `thenUs` \ uniq ->
644 returnUs (mkSysLocal SLIT("stg") uniq ty mkUnknownSrcLoc)
648 mkStgLets :: [StgBinding]
649 -> StgExpr -- body of let
652 mkStgLets binds body = foldr StgLet body binds