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 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 isExported binder then
201 [StgNonRec binder stg_rhs] -- Retain it
206 StgRhsClosure cc bi fvs upd [] (StgApp atom [] lvs) ->
207 -- Trivial RHS, so augment envt, and ditch the binding
208 returnUs (triv_binds, new_env, rhs_binds)
210 new_env = addOneToIdEnv env binder atom
212 StgRhsCon cc con_id [] ->
213 -- Trivial RHS, so augment envt, and ditch the binding
214 returnUs (triv_binds, new_env, rhs_binds)
216 new_env = addOneToIdEnv env binder (StgVarArg con_id)
218 other -> -- Non-trivial RHS, so don't augment envt
219 returnUs ([StgNonRec binder stg_rhs], env, rhs_binds)
221 coreBindToStg env (Rec pairs)
222 = -- NB: *** WE DO NOT CHECK FOR TRIV_BINDS in REC BIND ****
225 (binders, rhss) = unzip pairs
227 mapAndUnzipUs (coreRhsToStg env) rhss `thenUs` \ (stg_rhss, rhs_binds) ->
228 returnUs ([StgRec (binders `zip` stg_rhss)], env, unionManyBags rhs_binds)
232 %************************************************************************
234 \subsection[coreToStg-rhss]{Converting right hand sides}
236 %************************************************************************
239 coreRhsToStg :: StgEnv -> CoreExpr -> UniqSM (StgRhs, Bag StgBinding)
241 coreRhsToStg env core_rhs
242 = coreExprToStg env core_rhs `thenUs` \ (stg_expr, stg_binds) ->
244 let stg_rhs = case stg_expr of
245 StgLet (StgNonRec var1 rhs) (StgApp (StgVarArg var2) [] _)
246 | var1 == var2 -> rhs
247 -- This curious stuff is to unravel what a lambda turns into
248 -- We have to do it this way, rather than spot a lambda in the
251 StgCon con args _ -> StgRhsCon noCostCentre con args
253 other -> StgRhsClosure noCostCentre -- No cost centre (ToDo?)
256 Updatable -- Be pessimistic
260 returnUs (stg_rhs, stg_binds)
264 %************************************************************************
266 \subsection[coreToStg-lits]{Converting literals}
268 %************************************************************************
270 Literals: the NoRep kind need to be de-no-rep'd.
271 We always replace them with a simple variable, and float a suitable
272 binding out to the top level.
274 If an Integer is small enough (Haskell implementations must support
275 Ints in the range $[-2^29+1, 2^29-1]$), wrap it up in @int2Integer@;
276 otherwise, wrap with @litString2Integer@.
279 tARGET_MIN_INT, tARGET_MAX_INT :: Integer
280 tARGET_MIN_INT = -536870912
281 tARGET_MAX_INT = 536870912
283 litToStgArg :: Literal -> UniqSM (StgArg, Bag StgBinding)
285 litToStgArg (NoRepStr s)
286 = newStgVar stringTy `thenUs` \ var ->
288 rhs = StgRhsClosure noCostCentre -- No cost centre (ToDo?)
291 Updatable -- WAS: ReEntrant (see note below)
295 -- We used not to update strings, so that they wouldn't clog up the heap,
296 -- but instead be unpacked each time. But on some programs that costs a lot
297 -- [eg hpg], so now we update them.
299 val = if (any is_NUL (_UNPK_ s)) then -- must cater for NULs in literal string
300 StgApp (StgVarArg unpackCString2Id)
301 [StgLitArg (MachStr s),
302 StgLitArg (mkMachInt (toInteger (_LENGTH_ s)))]
305 StgApp (StgVarArg unpackCStringId)
306 [StgLitArg (MachStr s)]
309 returnUs (StgVarArg var, unitBag (StgNonRec var rhs))
313 litToStgArg (NoRepInteger i integer_ty)
314 -- extremely convenient to look out for a few very common
316 | i == 0 = returnUs (StgVarArg integerZeroId, emptyBag)
317 | i == 1 = returnUs (StgVarArg integerPlusOneId, emptyBag)
318 | i == 2 = returnUs (StgVarArg integerPlusTwoId, emptyBag)
319 | i == (-1) = returnUs (StgVarArg integerMinusOneId, emptyBag)
322 = newStgVar integer_ty `thenUs` \ var ->
324 rhs = StgRhsClosure noCostCentre -- No cost centre (ToDo?)
327 Updatable -- Update an integer
332 | i > tARGET_MIN_INT && i < tARGET_MAX_INT
333 = -- Start from an Int
334 StgPrim Int2IntegerOp [StgLitArg (mkMachInt i)] bOGUS_LVs
337 = -- Start from a string
338 StgPrim Addr2IntegerOp [StgLitArg (MachStr (_PK_ (show i)))] bOGUS_LVs
340 returnUs (StgVarArg var, unitBag (StgNonRec var rhs))
342 litToStgArg (NoRepRational r rational_ty)
343 = --ASSERT(is_rational_ty)
344 (if is_rational_ty then \x->x else pprTrace "litToStgArg:not rational?" (pprType PprDebug rational_ty)) $
345 litToStgArg (NoRepInteger (numerator r) integer_ty) `thenUs` \ (num_atom, binds1) ->
346 litToStgArg (NoRepInteger (denominator r) integer_ty) `thenUs` \ (denom_atom, binds2) ->
347 newStgVar rational_ty `thenUs` \ var ->
349 rhs = StgRhsCon noCostCentre -- No cost centre (ToDo?)
350 ratio_data_con -- Constructor
351 [num_atom, denom_atom]
353 returnUs (StgVarArg var, binds1 `unionBags`
355 unitBag (StgNonRec var rhs))
357 (is_rational_ty, ratio_data_con, integer_ty)
358 = case (maybeAppDataTyCon rational_ty) of
359 Just (tycon, [i_ty], [con])
360 -> ASSERT(is_integer_ty i_ty)
361 (uniqueOf tycon == ratioTyConKey, con, i_ty)
363 _ -> (False, panic "ratio_data_con", panic "integer_ty")
366 = case (maybeAppDataTyCon ty) of
367 Just (tycon, [], _) -> uniqueOf tycon == integerTyConKey
370 litToStgArg other_lit = returnUs (StgLitArg other_lit, emptyBag)
374 %************************************************************************
376 \subsection[coreToStg-atoms{Converting atoms}
378 %************************************************************************
381 coreArgsToStg :: StgEnv -> [CoreArg] -> UniqSM ([Type], [StgArg], Bag StgBinding)
383 coreArgsToStg env [] = returnUs ([], [], emptyBag)
384 coreArgsToStg env (a:as)
385 = coreArgsToStg env as `thenUs` \ (tys, args, binds) ->
386 do_arg a tys args binds
388 do_arg a trest vrest binds
390 TyArg t -> returnUs (t:trest, vrest, binds)
391 UsageArg u -> returnUs (trest, vrest, binds)
392 VarArg v -> returnUs (trest, stgLookup env v : vrest, binds)
393 LitArg i -> litToStgArg i `thenUs` \ (v, bs) ->
394 returnUs (trest, v:vrest, bs `unionBags` binds)
397 There's not anything interesting we can ASSERT about \tr{var} if it
398 isn't in the StgEnv. (WDP 94/06)
400 stgLookup :: StgEnv -> Id -> StgArg
402 stgLookup env var = case (lookupIdEnv env var) of
403 Nothing -> StgVarArg var
407 %************************************************************************
409 \subsection[coreToStg-exprs]{Converting core expressions}
411 %************************************************************************
414 coreExprToStg :: StgEnv
416 -> UniqSM (StgExpr, -- Result
417 Bag StgBinding) -- Float these to top level
421 coreExprToStg env (Lit lit)
422 = litToStgArg lit `thenUs` \ (atom, binds) ->
423 returnUs (StgApp atom [] bOGUS_LVs, binds)
425 coreExprToStg env (Var var)
426 = returnUs (StgApp (stgLookup env var) [] bOGUS_LVs, emptyBag)
428 coreExprToStg env (Con con args)
429 = coreArgsToStg env args `thenUs` \ (types, stg_atoms, stg_binds) ->
431 spec_con = mkSpecialisedCon con types
433 returnUs (StgCon spec_con stg_atoms bOGUS_LVs, stg_binds)
435 coreExprToStg env (Prim op args)
436 = coreArgsToStg env args `thenUs` \ (_, stg_atoms, stg_binds) ->
437 returnUs (StgPrim op stg_atoms bOGUS_LVs, stg_binds)
440 %************************************************************************
442 \subsubsection[coreToStg-lambdas]{Lambda abstractions}
444 %************************************************************************
447 coreExprToStg env expr@(Lam _ _)
449 (_,_, binders, body) = collectBinders expr
451 coreExprToStg env body `thenUs` \ stuff@(stg_body, binds) ->
453 if null binders then -- it was all type/usage binders; tossed
456 newStgVar (coreExprType expr) `thenUs` \ var ->
458 (StgLet (StgNonRec var (StgRhsClosure noCostCentre
461 ReEntrant -- binders is non-empty
464 (StgApp (StgVarArg var) [] bOGUS_LVs),
468 %************************************************************************
470 \subsubsection[coreToStg-applications]{Applications}
472 %************************************************************************
475 coreExprToStg env expr@(App _ _)
477 (fun, _, _, args) = collectArgs expr
479 -- Deal with the arguments
480 coreArgsToStg env args `thenUs` \ (_, stg_args, arg_binds) ->
482 -- Now deal with the function
484 Var fun_id -> returnUs (StgApp (stgLookup env fun_id) stg_args bOGUS_LVs, arg_binds)
486 other -> -- A non-variable applied to things; better let-bind it.
487 newStgVar (coreExprType fun) `thenUs` \ fun_id ->
488 coreExprToStg env fun `thenUs` \ (stg_fun, fun_binds) ->
490 fun_rhs = StgRhsClosure noCostCentre -- No cost centre (ToDo?)
493 SingleEntry -- Only entered once
497 returnUs (StgLet (StgNonRec fun_id fun_rhs)
498 (StgApp (StgVarArg fun_id) stg_args bOGUS_LVs),
499 arg_binds `unionBags` fun_binds)
502 %************************************************************************
504 \subsubsection[coreToStg-cases]{Case expressions}
506 %************************************************************************
508 At this point, we *mangle* cases involving fork# and par# in the
509 discriminant. The original templates for these primops (see
510 @PrelVals.lhs@) constructed case expressions with boolean results
511 solely to fool the strictness analyzer, the simplifier, and anyone
512 else who might want to fool with the evaluation order. Now, we
513 believe that once the translation to STG code is performed, our
514 evaluation order is safe. Therefore, we convert expressions of the
528 coreExprToStg env (Case discrim@(Prim op _) alts)
530 = getUnique `thenUs` \ uniq ->
531 coreExprToStg env discrim `thenUs` \ (stg_discrim, discrim_binds) ->
532 alts_to_stg alts `thenUs` \ (stg_alts, alts_binds) ->
539 discrim_binds `unionBags` alts_binds
542 funnyParallelOp SeqOp = True
543 funnyParallelOp ParOp = True
544 funnyParallelOp ForkOp = True
545 funnyParallelOp _ = False
547 discrim_ty = coreExprType discrim
549 alts_to_stg (PrimAlts _ (BindDefault binder rhs))
550 = coreExprToStg env rhs `thenUs` \ (stg_rhs, rhs_binds) ->
552 stg_deflt = StgBindDefault binder False stg_rhs
554 returnUs (StgPrimAlts discrim_ty [] stg_deflt, rhs_binds)
556 -- OK, back to real life...
558 coreExprToStg env (Case discrim alts)
559 = coreExprToStg env discrim `thenUs` \ (stg_discrim, discrim_binds) ->
560 alts_to_stg discrim alts `thenUs` \ (stg_alts, alts_binds) ->
561 getUnique `thenUs` \ uniq ->
568 discrim_binds `unionBags` alts_binds
571 discrim_ty = coreExprType discrim
572 (_, discrim_ty_args, _) = getAppDataTyConExpandingDicts discrim_ty
574 alts_to_stg discrim (AlgAlts alts deflt)
575 = default_to_stg discrim deflt `thenUs` \ (stg_deflt, deflt_binds) ->
576 mapAndUnzipUs boxed_alt_to_stg alts `thenUs` \ (stg_alts, alts_binds) ->
577 returnUs (StgAlgAlts discrim_ty stg_alts stg_deflt,
578 deflt_binds `unionBags` unionManyBags alts_binds)
580 boxed_alt_to_stg (con, bs, rhs)
581 = coreExprToStg env rhs `thenUs` \ (stg_rhs, rhs_binds) ->
582 returnUs ((spec_con, bs, [ True | b <- bs ]{-bogus use mask-}, stg_rhs),
585 spec_con = mkSpecialisedCon con discrim_ty_args
587 alts_to_stg discrim (PrimAlts alts deflt)
588 = default_to_stg discrim deflt `thenUs` \ (stg_deflt,deflt_binds) ->
589 mapAndUnzipUs unboxed_alt_to_stg alts `thenUs` \ (stg_alts, alts_binds) ->
590 returnUs (StgPrimAlts discrim_ty stg_alts stg_deflt,
591 deflt_binds `unionBags` unionManyBags alts_binds)
593 unboxed_alt_to_stg (lit, rhs)
594 = coreExprToStg env rhs `thenUs` \ (stg_rhs, rhs_binds) ->
595 returnUs ((lit, stg_rhs), rhs_binds)
597 default_to_stg discrim NoDefault
598 = returnUs (StgNoDefault, emptyBag)
600 default_to_stg discrim (BindDefault binder rhs)
601 = coreExprToStg new_env rhs `thenUs` \ (stg_rhs, rhs_binds) ->
602 returnUs (StgBindDefault binder True{-used? no it is lying-} stg_rhs,
606 -- We convert case x of {...; x' -> ...x'...}
608 -- case x of {...; _ -> ...x... }
610 -- See notes in SimplCase.lhs, near simplDefault for the reasoning.
611 -- It's quite easily done: simply extend the environment to bind the
612 -- default binder to the scrutinee.
614 new_env = case discrim of
615 Var v -> addOneToIdEnv env binder (stgLookup env v)
619 %************************************************************************
621 \subsubsection[coreToStg-let(rec)]{Let and letrec expressions}
623 %************************************************************************
626 coreExprToStg env (Let bind body)
627 = coreBindToStg env bind `thenUs` \ (stg_binds, new_env, float_binds1) ->
628 coreExprToStg new_env body `thenUs` \ (stg_body, float_binds2) ->
629 returnUs (mkStgLets stg_binds stg_body, float_binds1 `unionBags` float_binds2)
633 %************************************************************************
635 \subsubsection[coreToStg-scc]{SCC expressions}
637 %************************************************************************
639 Covert core @scc@ expression directly to STG @scc@ expression.
641 coreExprToStg env (SCC cc expr)
642 = coreExprToStg env expr `thenUs` \ (stg_expr, binds) ->
643 returnUs (StgSCC (coreExprType expr) cc stg_expr, binds)
647 coreExprToStg env (Coerce c ty expr)
648 = coreExprToStg env expr -- `thenUs` \ (stg_expr, binds) ->
649 -- returnUs (StgSCC (coreExprType expr) cc stg_expr, binds)
653 %************************************************************************
655 \subsection[coreToStg-misc]{Miscellaneous helping functions}
657 %************************************************************************
663 newStgVar :: Type -> UniqSM Id
665 = getUnique `thenUs` \ uniq ->
666 returnUs (mkSysLocal SLIT("stg") uniq ty mkUnknownSrcLoc)
670 mkStgLets :: [StgBinding]
671 -> StgExpr -- body of let
674 mkStgLets binds body = foldr StgLet body binds