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,
29 SYN_IE(IdEnv), GenId{-instance NamedThing-}
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 ( mkUnknownSrcLoc )
39 import TyCon ( TyCon{-instance Uniquable-} )
40 import Type ( maybeAppDataTyCon, getAppDataTyConExpandingDicts )
41 import TysWiredIn ( stringTy )
42 import Unique ( integerTyConKey, ratioTyConKey, Unique{-instance Eq-} )
43 import UniqSupply -- all of it, really
44 import Util ( panic, assertPanic, pprTrace{-ToDo:rm-} )
45 import Pretty--ToDo:rm
46 import PprStyle--ToDo:rm
47 import PprType --ToDo:rm
48 import Outputable--ToDo:rm
49 import PprEnv--ToDo:rm
51 isLeakFreeType x y = False -- safe option; ToDo
55 *************** OVERVIEW *********************
58 The business of this pass is to convert Core to Stg. On the way:
60 * We discard type lambdas and applications. In so doing we discard
61 "trivial" bindings such as
63 where t1, t2 are types
65 * We make the representation of NoRep literals explicit, and
66 float their bindings to the top level
68 * We do *not* pin on the correct free/live var info; that's done later.
69 Instead we use bOGUS_LVS and _FVS as a placeholder.
71 * We convert case x of {...; x' -> ...x'...}
73 case x of {...; _ -> ...x... }
75 See notes in SimplCase.lhs, near simplDefault for the reasoning here.
78 %************************************************************************
80 \subsection[coreToStg-programs]{Converting a core program and core bindings}
82 %************************************************************************
84 Because we're going to come across ``boring'' bindings like
85 \tr{let x = /\ tyvars -> y in ...}, we want to keep a small
86 environment, so we can just replace all occurrences of \tr{x}
90 type StgEnv = IdEnv StgArg
93 No free/live variable information is pinned on in this pass; it's added
95 we use @bOGUS_LVs@ and @bOGUS_FVs@ as placeholders.
98 bOGUS_LVs :: StgLiveVars
99 bOGUS_LVs = panic "bOGUS_LVs" -- emptyUniqSet (used when pprTracing)
102 bOGUS_FVs = panic "bOGUS_FVs" -- [] (ditto)
106 topCoreBindsToStg :: UniqSupply -- name supply
107 -> [CoreBinding] -- input
108 -> [StgBinding] -- output
110 topCoreBindsToStg us core_binds
111 = case (initUs us (binds_to_stg nullIdEnv core_binds)) of
114 binds_to_stg :: StgEnv -> [CoreBinding] -> UniqSM [StgBinding]
116 binds_to_stg env [] = returnUs []
117 binds_to_stg env (b:bs)
118 = do_top_bind env b `thenUs` \ (new_b, new_env, float_binds) ->
119 binds_to_stg new_env bs `thenUs` \ new_bs ->
120 returnUs (bagToList float_binds ++ -- Literals
124 do_top_bind env bind@(Rec pairs)
125 = coreBindToStg env bind
127 do_top_bind env bind@(NonRec var rhs)
128 = coreBindToStg env bind `thenUs` \ (stg_binds, new_env, float_binds) ->
131 ppr_blah xs = ppInterleave ppComma (map pp_x xs)
132 pp_x (u,x) = ppBesides [pprUnique u, ppStr ": ", ppr PprDebug x]
134 pprTrace "do_top_bind:" (ppAbove (ppr PprDebug stg_binds) (ppr_blah (ufmToList new_env))) $
137 [StgNonRec var (StgRhsClosure cc bi fvs u [] rhs_body)] ->
138 -- Mega-special case; there's still a binding there
139 -- no fvs (of course), *no args*, "let" rhs
141 (extra_float_binds, rhs_body') = seek_liftable [] rhs_body
143 returnUs (extra_float_binds ++
144 [StgNonRec var (StgRhsClosure cc bi fvs u [] rhs_body')],
148 other -> returnUs (stg_binds, new_env, float_binds)
151 -- HACK: look for very simple, obviously-liftable bindings
152 -- that can come up to the top level; those that couldn't
153 -- 'cause they were big-lambda constrained in the Core world.
155 seek_liftable :: [StgBinding] -- accumulator...
156 -> StgExpr -- look for top-lev liftables
157 -> ([StgBinding], StgExpr) -- result
159 seek_liftable acc expr@(StgLet inner_bind body)
160 | is_liftable inner_bind
161 = seek_liftable (inner_bind : acc) body
163 seek_liftable acc other_expr = (reverse acc, other_expr) -- Finished
166 is_liftable (StgNonRec binder (StgRhsClosure _ _ _ _ args body))
167 = not (null args) -- it's manifestly a function...
168 || isLeakFreeType [] (idType binder)
170 -- ToDo: use a decent manifestlyWHNF function for STG?
172 is_whnf (StgCon _ _ _) = True
173 is_whnf (StgApp (StgVarArg v) _ _) = isBottomingId v
174 is_whnf other = False
176 is_liftable (StgRec [(_, StgRhsClosure _ _ _ _ args body)])
177 = not (null args) -- it's manifestly a (recursive) function...
179 is_liftable anything_else = False
182 %************************************************************************
184 \subsection[coreToStg-binds]{Converting bindings}
186 %************************************************************************
189 coreBindToStg :: StgEnv
191 -> UniqSM ([StgBinding], -- Empty or singleton
193 Bag StgBinding) -- Floats
195 coreBindToStg env (NonRec binder rhs)
196 = coreRhsToStg env rhs `thenUs` \ (stg_rhs, rhs_binds) ->
199 -- Binds to return if RHS is trivial
200 triv_binds = if externallyVisibleId binder then
201 -- pprTrace "coreBindToStg:keeping:" (ppCat [ppr PprDebug binder, ppr PprDebug (externallyVisibleId binder)]) $
202 [StgNonRec binder stg_rhs] -- Retain it
204 -- pprTrace "coreBindToStg:tossing:" (ppCat [ppr PprDebug binder, ppr PprDebug (externallyVisibleId binder)]) $
208 StgRhsClosure cc bi fvs upd [] (StgApp atom [] lvs) ->
209 -- Trivial RHS, so augment envt, and ditch the binding
210 returnUs (triv_binds, new_env, rhs_binds)
212 new_env = addOneToIdEnv env binder atom
214 StgRhsCon cc con_id [] ->
215 -- Trivial RHS, so augment envt, and ditch the binding
216 returnUs (triv_binds, new_env, rhs_binds)
218 new_env = addOneToIdEnv env binder (StgVarArg con_id)
220 other -> -- Non-trivial RHS, so don't augment envt
221 returnUs ([StgNonRec binder stg_rhs], env, rhs_binds)
223 coreBindToStg env (Rec pairs)
224 = -- NB: *** WE DO NOT CHECK FOR TRIV_BINDS in REC BIND ****
227 (binders, rhss) = unzip pairs
229 mapAndUnzipUs (coreRhsToStg env) rhss `thenUs` \ (stg_rhss, rhs_binds) ->
230 returnUs ([StgRec (binders `zip` stg_rhss)], env, unionManyBags rhs_binds)
234 %************************************************************************
236 \subsection[coreToStg-rhss]{Converting right hand sides}
238 %************************************************************************
241 coreRhsToStg :: StgEnv -> CoreExpr -> UniqSM (StgRhs, Bag StgBinding)
243 coreRhsToStg env core_rhs
244 = coreExprToStg env core_rhs `thenUs` \ (stg_expr, stg_binds) ->
246 let stg_rhs = case stg_expr of
247 StgLet (StgNonRec var1 rhs) (StgApp (StgVarArg var2) [] _)
248 | var1 == var2 -> rhs
249 -- This curious stuff is to unravel what a lambda turns into
250 -- We have to do it this way, rather than spot a lambda in the
253 StgCon con args _ -> StgRhsCon noCostCentre con args
255 other -> StgRhsClosure noCostCentre -- No cost centre (ToDo?)
258 Updatable -- Be pessimistic
262 returnUs (stg_rhs, stg_binds)
266 %************************************************************************
268 \subsection[coreToStg-lits]{Converting literals}
270 %************************************************************************
272 Literals: the NoRep kind need to be de-no-rep'd.
273 We always replace them with a simple variable, and float a suitable
274 binding out to the top level.
276 If an Integer is small enough (Haskell implementations must support
277 Ints in the range $[-2^29+1, 2^29-1]$), wrap it up in @int2Integer@;
278 otherwise, wrap with @litString2Integer@.
281 tARGET_MIN_INT, tARGET_MAX_INT :: Integer
282 tARGET_MIN_INT = -536870912
283 tARGET_MAX_INT = 536870912
285 litToStgArg :: Literal -> UniqSM (StgArg, Bag StgBinding)
287 litToStgArg (NoRepStr s)
288 = newStgVar stringTy `thenUs` \ var ->
290 rhs = StgRhsClosure noCostCentre -- No cost centre (ToDo?)
293 Updatable -- WAS: ReEntrant (see note below)
297 -- We used not to update strings, so that they wouldn't clog up the heap,
298 -- but instead be unpacked each time. But on some programs that costs a lot
299 -- [eg hpg], so now we update them.
301 val = if (any is_NUL (_UNPK_ s)) then -- must cater for NULs in literal string
302 StgApp (StgVarArg unpackCString2Id)
303 [StgLitArg (MachStr s),
304 StgLitArg (mkMachInt (toInteger (_LENGTH_ s)))]
307 StgApp (StgVarArg unpackCStringId)
308 [StgLitArg (MachStr s)]
311 returnUs (StgVarArg var, unitBag (StgNonRec var rhs))
315 litToStgArg (NoRepInteger i integer_ty)
316 -- extremely convenient to look out for a few very common
318 | i == 0 = returnUs (StgVarArg integerZeroId, emptyBag)
319 | i == 1 = returnUs (StgVarArg integerPlusOneId, emptyBag)
320 | i == 2 = returnUs (StgVarArg integerPlusTwoId, emptyBag)
321 | i == (-1) = returnUs (StgVarArg integerMinusOneId, emptyBag)
324 = newStgVar integer_ty `thenUs` \ var ->
326 rhs = StgRhsClosure noCostCentre -- No cost centre (ToDo?)
329 Updatable -- Update an integer
334 | i > tARGET_MIN_INT && i < tARGET_MAX_INT
335 = -- Start from an Int
336 StgPrim Int2IntegerOp [StgLitArg (mkMachInt i)] bOGUS_LVs
339 = -- Start from a string
340 StgPrim Addr2IntegerOp [StgLitArg (MachStr (_PK_ (show i)))] bOGUS_LVs
342 returnUs (StgVarArg var, unitBag (StgNonRec var rhs))
344 litToStgArg (NoRepRational r rational_ty)
345 = --ASSERT(is_rational_ty)
346 (if is_rational_ty then \x->x else pprTrace "litToStgArg:not rational?" (pprType PprDebug rational_ty)) $
347 litToStgArg (NoRepInteger (numerator r) integer_ty) `thenUs` \ (num_atom, binds1) ->
348 litToStgArg (NoRepInteger (denominator r) integer_ty) `thenUs` \ (denom_atom, binds2) ->
349 newStgVar rational_ty `thenUs` \ var ->
351 rhs = StgRhsCon noCostCentre -- No cost centre (ToDo?)
352 ratio_data_con -- Constructor
353 [num_atom, denom_atom]
355 returnUs (StgVarArg var, binds1 `unionBags`
357 unitBag (StgNonRec var rhs))
359 (is_rational_ty, ratio_data_con, integer_ty)
360 = case (maybeAppDataTyCon rational_ty) of
361 Just (tycon, [i_ty], [con])
362 -> ASSERT(is_integer_ty i_ty)
363 (uniqueOf tycon == ratioTyConKey, con, i_ty)
365 _ -> (False, panic "ratio_data_con", panic "integer_ty")
368 = case (maybeAppDataTyCon ty) of
369 Just (tycon, [], _) -> uniqueOf tycon == integerTyConKey
372 litToStgArg other_lit = returnUs (StgLitArg other_lit, emptyBag)
376 %************************************************************************
378 \subsection[coreToStg-atoms{Converting atoms}
380 %************************************************************************
383 coreArgsToStg :: StgEnv -> [CoreArg] -> UniqSM ([Type], [StgArg], Bag StgBinding)
385 coreArgsToStg env [] = returnUs ([], [], emptyBag)
386 coreArgsToStg env (a:as)
387 = coreArgsToStg env as `thenUs` \ (tys, args, binds) ->
388 do_arg a tys args binds
390 do_arg a trest vrest binds
392 TyArg t -> returnUs (t:trest, vrest, binds)
393 UsageArg u -> returnUs (trest, vrest, binds)
394 VarArg v -> returnUs (trest, stgLookup env v : vrest, binds)
395 LitArg i -> litToStgArg i `thenUs` \ (v, bs) ->
396 returnUs (trest, v:vrest, bs `unionBags` binds)
399 There's not anything interesting we can ASSERT about \tr{var} if it
400 isn't in the StgEnv. (WDP 94/06)
402 stgLookup :: StgEnv -> Id -> StgArg
404 stgLookup env var = case (lookupIdEnv env var) of
405 Nothing -> StgVarArg var
409 %************************************************************************
411 \subsection[coreToStg-exprs]{Converting core expressions}
413 %************************************************************************
416 coreExprToStg :: StgEnv
418 -> UniqSM (StgExpr, -- Result
419 Bag StgBinding) -- Float these to top level
423 coreExprToStg env (Lit lit)
424 = litToStgArg lit `thenUs` \ (atom, binds) ->
425 returnUs (StgApp atom [] bOGUS_LVs, binds)
427 coreExprToStg env (Var var)
428 = returnUs (StgApp (stgLookup env var) [] bOGUS_LVs, emptyBag)
430 coreExprToStg env (Con con args)
431 = coreArgsToStg env args `thenUs` \ (types, stg_atoms, stg_binds) ->
433 spec_con = mkSpecialisedCon con types
435 returnUs (StgCon spec_con stg_atoms bOGUS_LVs, stg_binds)
437 coreExprToStg env (Prim op args)
438 = coreArgsToStg env args `thenUs` \ (_, stg_atoms, stg_binds) ->
439 returnUs (StgPrim op stg_atoms bOGUS_LVs, stg_binds)
442 %************************************************************************
444 \subsubsection[coreToStg-lambdas]{Lambda abstractions}
446 %************************************************************************
449 coreExprToStg env expr@(Lam _ _)
451 (_,_, binders, body) = collectBinders expr
453 coreExprToStg env body `thenUs` \ stuff@(stg_body, binds) ->
455 if null binders then -- it was all type/usage binders; tossed
458 newStgVar (coreExprType expr) `thenUs` \ var ->
460 (StgLet (StgNonRec var (StgRhsClosure noCostCentre
463 ReEntrant -- binders is non-empty
466 (StgApp (StgVarArg var) [] bOGUS_LVs),
470 %************************************************************************
472 \subsubsection[coreToStg-applications]{Applications}
474 %************************************************************************
477 coreExprToStg env expr@(App _ _)
479 (fun,args) = collect_args expr []
481 -- Deal with the arguments
482 coreArgsToStg env args `thenUs` \ (_, stg_args, arg_binds) ->
484 -- Now deal with the function
486 (Var fun_id, _) -> -- A function Id, so do an StgApp; it's ok if
487 -- there are no arguments.
488 returnUs (StgApp (stgLookup env fun_id) stg_args bOGUS_LVs, arg_binds)
490 (non_var_fun, []) -> -- No value args, so recurse into the function
491 coreExprToStg env non_var_fun
493 other -> -- A non-variable applied to things; better let-bind it.
494 newStgVar (coreExprType fun) `thenUs` \ fun_id ->
495 coreExprToStg env fun `thenUs` \ (stg_fun, fun_binds) ->
497 fun_rhs = StgRhsClosure noCostCentre -- No cost centre (ToDo?)
500 SingleEntry -- Only entered once
504 returnUs (StgLet (StgNonRec fun_id fun_rhs)
505 (StgApp (StgVarArg fun_id) stg_args bOGUS_LVs),
506 arg_binds `unionBags` fun_binds)
508 -- Collect arguments, discarding type/usage applications
509 collect_args (App e (TyArg _)) args = collect_args e args
510 collect_args (App e (UsageArg _)) args = collect_args e args
511 collect_args (App fun arg) args = collect_args fun (arg:args)
512 collect_args fun args = (fun, args)
515 %************************************************************************
517 \subsubsection[coreToStg-cases]{Case expressions}
519 %************************************************************************
521 At this point, we *mangle* cases involving fork# and par# in the
522 discriminant. The original templates for these primops (see
523 @PrelVals.lhs@) constructed case expressions with boolean results
524 solely to fool the strictness analyzer, the simplifier, and anyone
525 else who might want to fool with the evaluation order. Now, we
526 believe that once the translation to STG code is performed, our
527 evaluation order is safe. Therefore, we convert expressions of the
541 coreExprToStg env (Case discrim@(Prim op _) alts)
543 = getUnique `thenUs` \ uniq ->
544 coreExprToStg env discrim `thenUs` \ (stg_discrim, discrim_binds) ->
545 alts_to_stg alts `thenUs` \ (stg_alts, alts_binds) ->
552 discrim_binds `unionBags` alts_binds
555 funnyParallelOp SeqOp = True
556 funnyParallelOp ParOp = True
557 funnyParallelOp ForkOp = True
558 funnyParallelOp _ = False
560 discrim_ty = coreExprType discrim
562 alts_to_stg (PrimAlts _ (BindDefault binder rhs))
563 = coreExprToStg env rhs `thenUs` \ (stg_rhs, rhs_binds) ->
565 stg_deflt = StgBindDefault binder False stg_rhs
567 returnUs (StgPrimAlts discrim_ty [] stg_deflt, rhs_binds)
569 -- OK, back to real life...
571 coreExprToStg env (Case discrim alts)
572 = coreExprToStg env discrim `thenUs` \ (stg_discrim, discrim_binds) ->
573 alts_to_stg discrim alts `thenUs` \ (stg_alts, alts_binds) ->
574 getUnique `thenUs` \ uniq ->
581 discrim_binds `unionBags` alts_binds
584 discrim_ty = coreExprType discrim
585 (_, discrim_ty_args, _) = getAppDataTyConExpandingDicts discrim_ty
587 alts_to_stg discrim (AlgAlts alts deflt)
588 = default_to_stg discrim deflt `thenUs` \ (stg_deflt, deflt_binds) ->
589 mapAndUnzipUs boxed_alt_to_stg alts `thenUs` \ (stg_alts, alts_binds) ->
590 returnUs (StgAlgAlts discrim_ty stg_alts stg_deflt,
591 deflt_binds `unionBags` unionManyBags alts_binds)
593 boxed_alt_to_stg (con, bs, rhs)
594 = coreExprToStg env rhs `thenUs` \ (stg_rhs, rhs_binds) ->
595 returnUs ((spec_con, bs, [ True | b <- bs ]{-bogus use mask-}, stg_rhs),
598 spec_con = mkSpecialisedCon con discrim_ty_args
600 alts_to_stg discrim (PrimAlts alts deflt)
601 = default_to_stg discrim deflt `thenUs` \ (stg_deflt,deflt_binds) ->
602 mapAndUnzipUs unboxed_alt_to_stg alts `thenUs` \ (stg_alts, alts_binds) ->
603 returnUs (StgPrimAlts discrim_ty stg_alts stg_deflt,
604 deflt_binds `unionBags` unionManyBags alts_binds)
606 unboxed_alt_to_stg (lit, rhs)
607 = coreExprToStg env rhs `thenUs` \ (stg_rhs, rhs_binds) ->
608 returnUs ((lit, stg_rhs), rhs_binds)
610 default_to_stg discrim NoDefault
611 = returnUs (StgNoDefault, emptyBag)
613 default_to_stg discrim (BindDefault binder rhs)
614 = coreExprToStg new_env rhs `thenUs` \ (stg_rhs, rhs_binds) ->
615 returnUs (StgBindDefault binder True{-used? no it is lying-} stg_rhs,
619 -- We convert case x of {...; x' -> ...x'...}
621 -- case x of {...; _ -> ...x... }
623 -- See notes in SimplCase.lhs, near simplDefault for the reasoning.
624 -- It's quite easily done: simply extend the environment to bind the
625 -- default binder to the scrutinee.
627 new_env = case discrim of
628 Var v -> addOneToIdEnv env binder (stgLookup env v)
632 %************************************************************************
634 \subsubsection[coreToStg-let(rec)]{Let and letrec expressions}
636 %************************************************************************
639 coreExprToStg env (Let bind body)
640 = coreBindToStg env bind `thenUs` \ (stg_binds, new_env, float_binds1) ->
641 coreExprToStg new_env body `thenUs` \ (stg_body, float_binds2) ->
642 returnUs (mkStgLets stg_binds stg_body, float_binds1 `unionBags` float_binds2)
646 %************************************************************************
648 \subsubsection[coreToStg-scc]{SCC expressions}
650 %************************************************************************
652 Covert core @scc@ expression directly to STG @scc@ expression.
654 coreExprToStg env (SCC cc expr)
655 = coreExprToStg env expr `thenUs` \ (stg_expr, binds) ->
656 returnUs (StgSCC (coreExprType expr) cc stg_expr, binds)
660 coreExprToStg env (Coerce c ty expr) = coreExprToStg env expr
664 %************************************************************************
666 \subsection[coreToStg-misc]{Miscellaneous helping functions}
668 %************************************************************************
674 newStgVar :: Type -> UniqSM Id
676 = getUnique `thenUs` \ uniq ->
677 returnUs (mkSysLocal SLIT("stg") uniq ty mkUnknownSrcLoc)
681 mkStgLets :: [StgBinding]
682 -> StgExpr -- body of let
685 mkStgLets binds body = foldr StgLet body binds