2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
4 %************************************************************************
6 \section[CoreToStg]{Converting core syntax to STG syntax}
8 %************************************************************************
10 Convert a @CoreSyntax@ program to a @StgSyntax@ program.
14 #include "HsVersions.h"
19 -- and to make the interface self-sufficient...
20 SplitUniqSupply, Id, CoreExpr, CoreBinding, StgBinding,
24 import PlainCore -- input
25 import AnnCoreSyn -- intermediate form on which all work is done
26 import StgSyn -- output
28 import Unique -- the UniqueSupply monadery used herein
30 import AbsPrel ( unpackCStringId, unpackCString2Id, stringTy,
31 integerTy, rationalTy, ratioDataCon,
32 PrimOp(..), -- For Int2IntegerOp etc
33 integerZeroId, integerPlusOneId,
34 integerPlusTwoId, integerMinusOneId
35 IF_ATTACK_PRAGMAS(COMMA mkListTy COMMA charTy)
36 IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp)
37 IF_ATTACK_PRAGMAS(COMMA pprPrimOp)
40 import AbsUniType ( isPrimType, isLeakFreeType, getUniDataTyCon )
41 import Bag -- Bag operations
42 import BasicLit ( mkMachInt, BasicLit(..), PrimKind ) -- ToDo: its use is ugly...
43 import CostCentre ( noCostCentre, CostCentre )
44 import Id ( mkSysLocal, getIdUniType, isBottomingId
45 IF_ATTACK_PRAGMAS(COMMA bottomIsGuaranteed)
48 import Maybes ( Maybe(..), catMaybes )
49 import Outputable ( isExported )
50 import Pretty -- debugging only!
51 import SpecTyFuns ( mkSpecialisedCon )
52 import SrcLoc ( SrcLoc, mkUnknownSrcLoc )
57 *************** OVERVIEW *********************
60 The business of this pass is to convert Core to Stg. On the way:
62 * We discard type lambdas and applications. In so doing we discard
63 "trivial" bindings such as
65 where t1, t2 are types
67 * We make the representation of NoRep literals explicit, and
68 float their bindings to the top level
70 * We do *not* pin on the correct free/live var info; that's done later.
71 Instead we use bOGUS_LVS and _FVS as a placeholder.
73 * We convert case x of {...; x' -> ...x'...}
75 case x of {...; _ -> ...x... }
77 See notes in SimplCase.lhs, near simplDefault for the reasoning here.
80 %************************************************************************
82 \subsection[coreToStg-programs]{Converting a core program and core bindings}
84 %************************************************************************
86 Because we're going to come across ``boring'' bindings like
87 \tr{let x = /\ tyvars -> y in ...}, we want to keep a small
88 environment, so we can just replace all occurrences of \tr{x}
92 type StgEnv = IdEnv PlainStgAtom
95 No free/live variable information is pinned on in this pass; it's added
97 we use @bOGUS_LVs@ and @bOGUS_FVs@ as placeholders.
100 bOGUS_LVs :: PlainStgLiveVars
101 bOGUS_LVs = panic "bOGUS_LVs" -- emptyUniqSet (used when pprTracing)
104 bOGUS_FVs = panic "bOGUS_FVs" -- [] (ditto)
108 topCoreBindsToStg :: SplitUniqSupply -- name supply
109 -> [PlainCoreBinding] -- input
110 -> [PlainStgBinding] -- output
112 topCoreBindsToStg us core_binds
113 = case (initSUs us (binds_to_stg nullIdEnv core_binds)) of
116 binds_to_stg :: StgEnv -> [PlainCoreBinding] -> SUniqSM [PlainStgBinding]
118 binds_to_stg env [] = returnSUs []
119 binds_to_stg env (b:bs)
120 = do_top_bind env b `thenSUs` \ (new_b, new_env, float_binds) ->
121 binds_to_stg new_env bs `thenSUs` \ new_bs ->
122 returnSUs (bagToList float_binds ++ -- Literals
126 do_top_bind env bind@(CoRec pairs)
127 = coreBindToStg env bind
129 do_top_bind env bind@(CoNonRec var rhs)
130 = coreBindToStg env bind `thenSUs` \ (stg_binds, new_env, float_binds) ->
133 ppr_blah xs = ppInterleave ppComma (map pp_x xs)
134 pp_x (u,x) = ppBesides [pprUnique u, ppStr ": ", ppr PprDebug x]
136 pprTrace "do_top_bind:" (ppAbove (ppr PprDebug stg_binds) (ppr_blah (ufmToList new_env))) $
139 [StgNonRec var (StgRhsClosure cc bi fvs u [] rhs_body)] ->
140 -- Mega-special case; there's still a binding there
141 -- no fvs (of course), *no args*, "let" rhs
143 (extra_float_binds, rhs_body') = seek_liftable [] rhs_body
145 returnSUs (extra_float_binds ++
146 [StgNonRec var (StgRhsClosure cc bi fvs u [] rhs_body')],
150 other -> returnSUs (stg_binds, new_env, float_binds)
153 -- HACK: look for very simple, obviously-liftable bindings
154 -- that can come up to the top level; those that couldn't
155 -- 'cause they were big-lambda constrained in the Core world.
157 seek_liftable :: [PlainStgBinding] -- accumulator...
158 -> PlainStgExpr -- look for top-lev liftables
159 -> ([PlainStgBinding], PlainStgExpr) -- result
161 seek_liftable acc expr@(StgLet inner_bind body)
162 | is_liftable inner_bind
163 = seek_liftable (inner_bind : acc) body
165 seek_liftable acc other_expr = (reverse acc, other_expr) -- Finished
168 is_liftable (StgNonRec binder (StgRhsClosure _ _ _ _ args body))
169 = not (null args) -- it's manifestly a function...
170 || isLeakFreeType [] (getIdUniType binder)
172 -- ToDo: use a decent manifestlyWHNF function for STG?
174 is_whnf (StgConApp _ _ _) = True
175 is_whnf (StgApp (StgVarAtom v) _ _) = isBottomingId v
176 is_whnf other = False
178 is_liftable (StgRec [(_, StgRhsClosure _ _ _ _ args body)])
179 = not (null args) -- it's manifestly a (recursive) function...
181 is_liftable anything_else = False
184 %************************************************************************
186 \subsection[coreToStg-binds]{Converting bindings}
188 %************************************************************************
191 coreBindToStg :: StgEnv
193 -> SUniqSM ([PlainStgBinding], -- Empty or singleton
195 Bag PlainStgBinding) -- Floats
197 coreBindToStg env (CoNonRec binder rhs)
198 = coreRhsToStg env rhs `thenSUs` \ (stg_rhs, rhs_binds) ->
201 -- Binds to return if RHS is trivial
202 triv_binds = if isExported binder then
203 [StgNonRec binder stg_rhs] -- Retain it
208 StgRhsClosure cc bi fvs upd [] (StgApp atom [] lvs) ->
209 -- Trivial RHS, so augment envt, and ditch the binding
210 returnSUs (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 returnSUs (triv_binds, new_env, rhs_binds)
218 new_env = addOneToIdEnv env binder (StgVarAtom con_id)
220 other -> -- Non-trivial RHS, so don't augment envt
221 returnSUs ([StgNonRec binder stg_rhs], env, rhs_binds)
223 coreBindToStg env (CoRec pairs)
224 = -- NB: *** WE DO NOT CHECK FOR TRIV_BINDS in REC BIND ****
227 (binders, rhss) = unzip pairs
229 mapAndUnzipSUs (coreRhsToStg env) rhss `thenSUs` \ (stg_rhss, rhs_binds) ->
230 returnSUs ([StgRec (binders `zip` stg_rhss)], env, unionManyBags rhs_binds)
234 %************************************************************************
236 \subsection[coreToStg-rhss]{Converting right hand sides}
238 %************************************************************************
241 coreRhsToStg :: StgEnv -> PlainCoreExpr -> SUniqSM (PlainStgRhs, Bag PlainStgBinding)
243 coreRhsToStg env core_rhs
244 = coreExprToStg env core_rhs `thenSUs` \ (stg_expr, stg_binds) ->
246 let stg_rhs = case stg_expr of
247 StgLet (StgNonRec var1 rhs) (StgApp (StgVarAtom 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 StgConApp con args _ -> StgRhsCon noCostCentre con args
255 other -> StgRhsClosure noCostCentre -- No cost centre (ToDo?)
258 Updatable -- Be pessimistic
262 returnSUs (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 litToStgAtom :: BasicLit -> SUniqSM (PlainStgAtom, Bag PlainStgBinding)
287 litToStgAtom (NoRepStr s)
288 = newStgVar stringTy `thenSUs` \ var ->
290 rhs = StgRhsClosure noCostCentre -- No cost centre (ToDo?)
293 Updatable -- OLD: 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 (StgVarAtom unpackCString2Id)
303 [StgLitAtom (MachStr s),
304 StgLitAtom (mkMachInt (toInteger (_LENGTH_ s)))]
307 StgApp (StgVarAtom unpackCStringId)
308 [StgLitAtom (MachStr s)]
311 returnSUs (StgVarAtom var, unitBag (StgNonRec var rhs))
315 litToStgAtom (NoRepInteger i)
316 -- extremely convenient to look out for a few very common
318 | i == 0 = returnSUs (StgVarAtom integerZeroId, emptyBag)
319 | i == 1 = returnSUs (StgVarAtom integerPlusOneId, emptyBag)
320 | i == 2 = returnSUs (StgVarAtom integerPlusTwoId, emptyBag)
321 | i == (-1) = returnSUs (StgVarAtom integerMinusOneId, emptyBag)
324 = newStgVar integerTy `thenSUs` \ 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 StgPrimApp Int2IntegerOp [StgLitAtom (mkMachInt i)] bOGUS_LVs
339 = -- Start from a string
340 StgPrimApp Addr2IntegerOp [StgLitAtom (MachStr (_PK_ (show i)))] bOGUS_LVs
342 returnSUs (StgVarAtom var, unitBag (StgNonRec var rhs))
344 litToStgAtom (NoRepRational r)
345 = litToStgAtom (NoRepInteger (numerator r)) `thenSUs` \ (num_atom, binds1) ->
346 litToStgAtom (NoRepInteger (denominator r)) `thenSUs` \ (denom_atom, binds2) ->
347 newStgVar rationalTy `thenSUs` \ var ->
349 rhs = StgRhsCon noCostCentre -- No cost centre (ToDo?)
350 ratioDataCon -- Constructor
351 [num_atom, denom_atom]
353 returnSUs (StgVarAtom var, binds1 `unionBags`
355 unitBag (StgNonRec var rhs))
357 litToStgAtom other_lit = returnSUs (StgLitAtom other_lit, emptyBag)
361 %************************************************************************
363 \subsection[coreToStg-atoms{Converting atoms}
365 %************************************************************************
368 coreAtomToStg :: StgEnv -> PlainCoreAtom -> SUniqSM (PlainStgAtom, Bag PlainStgBinding)
370 coreAtomToStg env (CoVarAtom var) = returnSUs (stgLookup env var, emptyBag)
371 coreAtomToStg env (CoLitAtom lit) = litToStgAtom lit
374 There's not anything interesting we can ASSERT about \tr{var} if it
375 isn't in the StgEnv. (WDP 94/06)
377 stgLookup :: StgEnv -> Id -> PlainStgAtom
379 stgLookup env var = case (lookupIdEnv env var) of
380 Nothing -> StgVarAtom var
384 %************************************************************************
386 \subsection[coreToStg-exprs]{Converting core expressions}
388 %************************************************************************
391 coreExprToStg :: StgEnv
393 -> SUniqSM (PlainStgExpr, -- Result
394 Bag PlainStgBinding) -- Float these to top level
398 coreExprToStg env (CoLit lit)
399 = litToStgAtom lit `thenSUs` \ (atom, binds) ->
400 returnSUs (StgApp atom [] bOGUS_LVs, binds)
402 coreExprToStg env (CoVar var)
403 = returnSUs (StgApp (stgLookup env var) [] bOGUS_LVs, emptyBag)
405 coreExprToStg env (CoCon con types args)
406 = mapAndUnzipSUs (coreAtomToStg env) args `thenSUs` \ (stg_atoms, stg_binds) ->
407 returnSUs (StgConApp spec_con stg_atoms bOGUS_LVs, unionManyBags stg_binds)
409 spec_con = mkSpecialisedCon con types
411 coreExprToStg env (CoPrim op tys args)
412 = mapAndUnzipSUs (coreAtomToStg env) args `thenSUs` \ (stg_atoms, stg_binds) ->
413 returnSUs (StgPrimApp op stg_atoms bOGUS_LVs, unionManyBags stg_binds)
416 %************************************************************************
418 \subsubsection[coreToStg-type-stuff]{Type application and abstraction}
420 %************************************************************************
422 This type information dies in this Core-to-STG translation.
425 coreExprToStg env (CoTyLam tyvar expr) = coreExprToStg env expr
426 coreExprToStg env (CoTyApp expr ty) = coreExprToStg env expr
429 %************************************************************************
431 \subsubsection[coreToStg-lambdas]{Lambda abstractions}
433 %************************************************************************
436 coreExprToStg env expr@(CoLam binders body)
437 = coreExprToStg env body `thenSUs` \ (stg_body, binds) ->
438 newStgVar (typeOfCoreExpr expr) `thenSUs` \ var ->
439 returnSUs (StgLet (StgNonRec var (StgRhsClosure noCostCentre
442 ReEntrant -- binders is non-empty
445 (StgApp (StgVarAtom var) [] bOGUS_LVs),
449 %************************************************************************
451 \subsubsection[coreToStg-applications]{Applications}
453 %************************************************************************
456 coreExprToStg env expr@(CoApp _ _)
457 = -- Deal with the arguments
458 mapAndUnzipSUs (coreAtomToStg env) args `thenSUs` \ (stg_args, arg_binds) ->
460 -- Now deal with the function
462 CoVar fun_id -> returnSUs (StgApp (stgLookup env fun_id) stg_args bOGUS_LVs,
463 unionManyBags arg_binds)
465 other -> -- A non-variable applied to things; better let-bind it.
466 newStgVar (typeOfCoreExpr fun) `thenSUs` \ fun_id ->
467 coreExprToStg env fun `thenSUs` \ (stg_fun, fun_binds) ->
469 fun_rhs = StgRhsClosure noCostCentre -- No cost centre (ToDo?)
472 SingleEntry -- Only entered once
476 returnSUs (StgLet (StgNonRec fun_id fun_rhs)
477 (StgApp (StgVarAtom fun_id) stg_args bOGUS_LVs),
478 unionManyBags arg_binds `unionBags`
481 (fun,args) = collect_args expr []
483 -- Collect arguments, discarding type applications
484 collect_args (CoApp fun arg) args = collect_args fun (arg:args)
485 collect_args (CoTyApp e t) args = collect_args e args
486 collect_args fun args = (fun, args)
489 %************************************************************************
491 \subsubsection[coreToStg-cases]{Case expressions}
493 %************************************************************************
495 At this point, we *mangle* cases involving fork# and par# in the
496 discriminant. The original templates for these primops (see
497 @PrelVals.lhs@) constructed case expressions with boolean results
498 solely to fool the strictness analyzer, the simplifier, and anyone
499 else who might want to fool with the evaluation order. Now, we
500 believe that once the translation to STG code is performed, our
501 evaluation order is safe. Therefore, we convert expressions of the
515 coreExprToStg env (CoCase discrim@(CoPrim op tys args) alts)
516 | funnyParallelOp op =
517 getSUnique `thenSUs` \ uniq ->
518 coreExprToStg env discrim `thenSUs` \ (stg_discrim, discrim_binds) ->
519 alts_to_stg alts `thenSUs` \ (stg_alts, alts_binds) ->
526 discrim_binds `unionBags` alts_binds
529 funnyParallelOp SeqOp = True
530 funnyParallelOp ParOp = True
531 funnyParallelOp ForkOp = True
532 funnyParallelOp _ = False
534 discrim_ty = typeOfCoreExpr discrim
536 alts_to_stg (CoPrimAlts _ (CoBindDefault binder rhs))
537 = coreExprToStg env rhs `thenSUs` \ (stg_rhs, rhs_binds) ->
539 stg_deflt = StgBindDefault binder False stg_rhs
541 returnSUs (StgPrimAlts discrim_ty [] stg_deflt, rhs_binds)
543 -- OK, back to real life...
545 coreExprToStg env (CoCase discrim alts)
546 = coreExprToStg env discrim `thenSUs` \ (stg_discrim, discrim_binds) ->
547 alts_to_stg discrim alts `thenSUs` \ (stg_alts, alts_binds) ->
548 getSUnique `thenSUs` \ uniq ->
555 discrim_binds `unionBags` alts_binds
558 discrim_ty = typeOfCoreExpr discrim
559 (_, discrim_ty_args, _) = getUniDataTyCon discrim_ty
561 alts_to_stg discrim (CoAlgAlts alts deflt)
562 = default_to_stg discrim deflt `thenSUs` \ (stg_deflt, deflt_binds) ->
563 mapAndUnzipSUs boxed_alt_to_stg alts `thenSUs` \ (stg_alts, alts_binds) ->
564 returnSUs (StgAlgAlts discrim_ty stg_alts stg_deflt,
565 deflt_binds `unionBags` unionManyBags alts_binds)
567 boxed_alt_to_stg (con, bs, rhs)
568 = coreExprToStg env rhs `thenSUs` \ (stg_rhs, rhs_binds) ->
569 returnSUs ((spec_con, bs, [ True | b <- bs ]{-bogus use mask-}, stg_rhs),
572 spec_con = mkSpecialisedCon con discrim_ty_args
574 alts_to_stg discrim (CoPrimAlts alts deflt)
575 = default_to_stg discrim deflt `thenSUs` \ (stg_deflt,deflt_binds) ->
576 mapAndUnzipSUs unboxed_alt_to_stg alts `thenSUs` \ (stg_alts, alts_binds) ->
577 returnSUs (StgPrimAlts discrim_ty stg_alts stg_deflt,
578 deflt_binds `unionBags` unionManyBags alts_binds)
580 unboxed_alt_to_stg (lit, rhs)
581 = coreExprToStg env rhs `thenSUs` \ (stg_rhs, rhs_binds) ->
582 returnSUs ((lit, stg_rhs), rhs_binds)
585 alts_to_stg (CoParAlgAlts tycon ctxt params alts deflt)
586 = default_to_stg deflt `thenSUs` \ stg_deflt ->
587 mapSUs boxed_alt_to_stg alts `thenSUs` \ stg_alts ->
588 returnSUs (StgParAlgAlts discrim_ty ctxt params stg_alts stg_deflt)
590 boxed_alt_to_stg (con, rhs)
591 = coreExprToStg env rhs `thenSUs` \ stg_rhs ->
592 returnSUs (con, stg_rhs)
594 alts_to_stg (CoParPrimAlts tycon ctxt alts deflt)
595 = default_to_stg deflt `thenSUs` \ stg_deflt ->
596 mapSUs unboxed_alt_to_stg alts `thenSUs` \ stg_alts ->
597 returnSUs (StgParPrimAlts discrim_ty ctxt stg_alts stg_deflt)
599 unboxed_alt_to_stg (lit, rhs)
600 = coreExprToStg env rhs `thenSUs` \ stg_rhs ->
601 returnSUs (lit, stg_rhs)
602 #endif {- Data Parallel Haskell -}
604 default_to_stg discrim CoNoDefault
605 = returnSUs (StgNoDefault, emptyBag)
607 default_to_stg discrim (CoBindDefault binder rhs)
608 = coreExprToStg new_env rhs `thenSUs` \ (stg_rhs, rhs_binds) ->
609 returnSUs (StgBindDefault binder True{-used? no it is lying-} stg_rhs,
613 -- We convert case x of {...; x' -> ...x'...}
615 -- case x of {...; _ -> ...x... }
617 -- See notes in SimplCase.lhs, near simplDefault for the reasoning.
618 -- It's quite easily done: simply extend the environment to bind the
619 -- default binder to the scrutinee.
621 new_env = case discrim of
622 CoVar v -> addOneToIdEnv env binder (stgLookup env v)
626 %************************************************************************
628 \subsubsection[coreToStg-let(rec)]{Let and letrec expressions}
630 %************************************************************************
633 coreExprToStg env (CoLet bind body)
634 = coreBindToStg env bind `thenSUs` \ (stg_binds, new_env, float_binds1) ->
635 coreExprToStg new_env body `thenSUs` \ (stg_body, float_binds2) ->
636 returnSUs (mkStgLets stg_binds stg_body, float_binds1 `unionBags` float_binds2)
640 %************************************************************************
642 \subsubsection[coreToStg-scc]{SCC expressions}
644 %************************************************************************
646 Covert core @scc@ expression directly to STG @scc@ expression.
648 coreExprToStg env (CoSCC cc expr)
649 = coreExprToStg env expr `thenSUs` \ (stg_expr, binds) ->
650 returnSUs (StgSCC (typeOfCoreExpr expr) cc stg_expr, binds)
653 %************************************************************************
655 \subsubsection[coreToStg-dataParallel]{Data Parallel expressions}
657 %************************************************************************
660 coreExprToStg env (_, AnnCoParCon con ctxt types args)
661 = mapAndUnzipSUs (arg2stg env) args `thenSUs` \ (stg_atoms, stg_binds) ->
662 returnSUs (mkStgLets (catMaybes stg_binds)
663 (StgParConApp con ctxt stg_atoms bOGUS_LVs))
665 coreExprToStg env (_,AnnCoParComm ctxt expr comm)
666 = coreExprToStg env expr `thenSUs` \ stg_expr ->
667 annComm_to_stg comm `thenSUs` \ (stg_comm,stg_binds) ->
668 returnSUs (mkStgLets (catMaybes stg_binds)
669 (StgParComm ctxt stg_expr stg_comm))
672 annComm_to_stg (AnnCoParSend args)
673 = mapAndUnzipSUs (arg2stg env) args `thenSUs` \ (stg_atoms, stg_binds) ->
674 returnSUs (StgParSend stg_atoms,stg_binds)
676 annComm_to_stg (AnnCoParFetch args)
677 = mapAndUnzipSUs (arg2stg env) args `thenSUs` \ (stg_atoms, stg_binds) ->
678 returnSUs (StgParFetch stg_atoms,stg_binds)
680 annComm_to_stg (AnnCoToPodized)
681 = returnSUs (StgToPodized,[])
682 annComm_to_stg (AnnCoFromPodized)
683 = returnSUs (StgFromPodized,[])
684 #endif {- Data Parallel Haskell -}
689 coreExprToStg env other = panic "coreExprToStg: it really failed here"
693 %************************************************************************
695 \subsection[coreToStg-misc]{Miscellaneous helping functions}
697 %************************************************************************
703 newStgVar :: UniType -> SUniqSM Id
705 = getSUnique `thenSUs` \ uniq ->
706 returnSUs (mkSysLocal SLIT("stg") uniq ty mkUnknownSrcLoc)
710 mkStgLets :: [PlainStgBinding]
711 -> PlainStgExpr -- body of let
714 mkStgLets binds body = foldr StgLet body binds