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, stringTy,
31 integerTy, rationalTy, ratioDataCon,
32 PrimOp(..), -- For Int2IntegerOp etc
33 integerZeroId, integerPlusOneId, integerMinusOneId
34 IF_ATTACK_PRAGMAS(COMMA mkListTy COMMA charTy)
35 IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp)
36 IF_ATTACK_PRAGMAS(COMMA pprPrimOp)
39 import AbsUniType ( isPrimType, isLeakFreeType, getUniDataTyCon )
40 import Bag -- Bag operations
41 import BasicLit ( mkMachInt, BasicLit(..), PrimKind ) -- ToDo: its use is ugly...
42 import CostCentre ( noCostCentre, CostCentre )
43 import Id ( mkSysLocal, getIdUniType, isBottomingId
44 IF_ATTACK_PRAGMAS(COMMA bottomIsGuaranteed)
47 import Maybes ( Maybe(..), catMaybes )
48 import Outputable ( isExported )
49 import Pretty -- debugging only!
50 import SpecTyFuns ( mkSpecialisedCon )
51 import SrcLoc ( SrcLoc, mkUnknownSrcLoc )
56 *************** OVERVIEW *********************
59 The business of this pass is to convert Core to Stg. On the way:
61 * We discard type lambdas and applications. In so doing we discard
62 "trivial" bindings such as
64 where t1, t2 are types
66 * We make the representation of NoRep literals explicit, and
67 float their bindings to the top level
69 * We do *not* pin on the correct free/live var info; that's done later.
70 Instead we use bOGUS_LVS and _FVS as a placeholder.
72 * We convert case x of {...; x' -> ...x'...}
74 case x of {...; _ -> ...x... }
76 See notes in SimplCase.lhs, near simplDefault for the reasoning here.
79 %************************************************************************
81 \subsection[coreToStg-programs]{Converting a core program and core bindings}
83 %************************************************************************
85 Because we're going to come across ``boring'' bindings like
86 \tr{let x = /\ tyvars -> y in ...}, we want to keep a small
87 environment, so we can just replace all occurrences of \tr{x}
91 type StgEnv = IdEnv PlainStgAtom
94 No free/live variable information is pinned on in this pass; it's added
96 we use @bOGUS_LVs@ and @bOGUS_FVs@ as placeholders.
99 bOGUS_LVs :: PlainStgLiveVars
100 bOGUS_LVs = panic "bOGUS_LVs"
103 bOGUS_FVs = panic "bOGUS_FVs"
107 topCoreBindsToStg :: SplitUniqSupply -- name supply
108 -> [PlainCoreBinding] -- input
109 -> [PlainStgBinding] -- output
111 topCoreBindsToStg us core_binds
112 = case (initSUs us (binds_to_stg nullIdEnv core_binds)) of
115 binds_to_stg :: StgEnv -> [PlainCoreBinding] -> SUniqSM [PlainStgBinding]
117 binds_to_stg env [] = returnSUs []
118 binds_to_stg env (b:bs)
119 = do_top_bind env b `thenSUs` \ (new_b, new_env, float_binds) ->
120 binds_to_stg new_env bs `thenSUs` \ new_bs ->
121 returnSUs (bagToList float_binds ++ -- Literals
125 do_top_bind env bind@(CoRec pairs)
126 = coreBindToStg env bind
128 do_top_bind env bind@(CoNonRec var rhs)
129 = coreBindToStg env bind `thenSUs` \ (stg_binds, new_env, float_binds) ->
132 [StgNonRec var (StgRhsClosure cc bi fvs u [] rhs_body)] ->
133 -- Mega-special case; there's still a binding there
134 -- no fvs (of course), *no args*, "let" rhs
136 (extra_float_binds, rhs_body') = seek_liftable [] rhs_body
138 returnSUs (extra_float_binds ++
139 [StgNonRec var (StgRhsClosure cc bi fvs u [] rhs_body')],
143 other -> returnSUs (stg_binds, new_env, float_binds)
146 -- HACK: look for very simple, obviously-liftable bindings
147 -- that can come up to the top level; those that couldn't
148 -- 'cause they were big-lambda constrained in the Core world.
150 seek_liftable :: [PlainStgBinding] -- accumulator...
151 -> PlainStgExpr -- look for top-lev liftables
152 -> ([PlainStgBinding], PlainStgExpr) -- result
154 seek_liftable acc expr@(StgLet inner_bind body)
155 | is_liftable inner_bind
156 = seek_liftable (inner_bind : acc) body
158 seek_liftable acc other_expr = (reverse acc, other_expr) -- Finished
161 is_liftable (StgNonRec binder (StgRhsClosure _ _ _ _ args body))
162 = not (null args) -- it's manifestly a function...
163 || isLeakFreeType [] (getIdUniType binder)
165 -- ToDo: use a decent manifestlyWHNF function for STG?
167 is_whnf (StgConApp _ _ _) = True
168 is_whnf (StgApp (StgVarAtom v) _ _) = isBottomingId v
169 is_whnf other = False
171 is_liftable (StgRec [(_, StgRhsClosure _ _ _ _ args body)])
172 = not (null args) -- it's manifestly a (recursive) function...
174 is_liftable anything_else = False
177 %************************************************************************
179 \subsection[coreToStg-binds]{Converting bindings}
181 %************************************************************************
184 coreBindToStg :: StgEnv
186 -> SUniqSM ([PlainStgBinding], -- Empty or singleton
188 Bag PlainStgBinding) -- Floats
190 coreBindToStg env (CoNonRec binder rhs)
191 = coreRhsToStg env rhs `thenSUs` \ (stg_rhs, rhs_binds) ->
194 -- Binds to return if RHS is trivial
195 triv_binds = if isExported binder then
196 [StgNonRec binder stg_rhs] -- Retain it
201 StgRhsClosure cc bi fvs upd [] (StgApp atom [] lvs) ->
202 -- Trivial RHS, so augment envt, and ditch the binding
203 returnSUs (triv_binds, new_env, rhs_binds)
205 new_env = addOneToIdEnv env binder atom
207 StgRhsCon cc con_id [] ->
208 -- Trivial RHS, so augment envt, and ditch the binding
209 returnSUs (triv_binds, new_env, rhs_binds)
211 new_env = addOneToIdEnv env binder (StgVarAtom con_id)
213 other -> -- Non-trivial RHS, so don't augment envt
214 returnSUs ([StgNonRec binder stg_rhs], env, rhs_binds)
216 coreBindToStg env (CoRec pairs)
217 = -- NB: *** WE DO NOT CHECK FOR TRIV_BINDS in REC BIND ****
220 (binders, rhss) = unzip pairs
222 mapAndUnzipSUs (coreRhsToStg env) rhss `thenSUs` \ (stg_rhss, rhs_binds) ->
223 returnSUs ([StgRec (binders `zip` stg_rhss)], env, unionManyBags rhs_binds)
227 %************************************************************************
229 \subsection[coreToStg-rhss]{Converting right hand sides}
231 %************************************************************************
234 coreRhsToStg :: StgEnv -> PlainCoreExpr -> SUniqSM (PlainStgRhs, Bag PlainStgBinding)
236 coreRhsToStg env core_rhs
237 = coreExprToStg env core_rhs `thenSUs` \ (stg_expr, stg_binds) ->
239 let stg_rhs = case stg_expr of
240 StgLet (StgNonRec var1 rhs) (StgApp (StgVarAtom var2) [] _)
241 | var1 == var2 -> rhs
242 -- This curious stuff is to unravel what a lambda turns into
243 -- We have to do it this way, rather than spot a lambda in the
246 StgConApp con args _ -> StgRhsCon noCostCentre con args
248 other -> StgRhsClosure noCostCentre -- No cost centre (ToDo?)
251 Updatable -- Be pessimistic
255 returnSUs (stg_rhs, stg_binds)
259 %************************************************************************
261 \subsection[coreToStg-lits]{Converting literals}
263 %************************************************************************
265 Literals: the NoRep kind need to be de-no-rep'd.
266 We always replace them with a simple variable, and float a suitable
267 binding out to the top level.
269 If an Integer is small enough (Haskell implementations must support
270 Ints in the range $[-2^29+1, 2^29-1]$), wrap it up in @int2Integer@;
271 otherwise, wrap with @litString2Integer@.
274 tARGET_MIN_INT, tARGET_MAX_INT :: Integer
275 tARGET_MIN_INT = -536870912
276 tARGET_MAX_INT = 536870912
278 litToStgAtom :: BasicLit -> SUniqSM (PlainStgAtom, Bag PlainStgBinding)
280 litToStgAtom (NoRepStr s)
281 = newStgVar stringTy `thenSUs` \ var ->
283 rhs = StgRhsClosure noCostCentre -- No cost centre (ToDo?)
286 Updatable -- OLD: ReEntrant (see note below)
290 -- We used not to update strings, so that they wouldn't clog up the heap,
291 -- but instead be unpacked each time. But on some programs that costs a lot
292 -- [eg hpg], so now we update them.
294 val = StgApp (StgVarAtom unpackCStringId)
295 [StgLitAtom (MachStr s)]
298 returnSUs (StgVarAtom var, unitBag (StgNonRec var rhs))
300 litToStgAtom (NoRepInteger i)
301 -- extremely convenient to look out for a few very common
303 | i == 0 = returnSUs (StgVarAtom integerZeroId, emptyBag)
304 | i == 1 = returnSUs (StgVarAtom integerPlusOneId, emptyBag)
305 | i == (-1) = returnSUs (StgVarAtom integerMinusOneId, emptyBag)
308 = newStgVar integerTy `thenSUs` \ var ->
310 rhs = StgRhsClosure noCostCentre -- No cost centre (ToDo?)
313 Updatable -- Update an integer
318 | i > tARGET_MIN_INT && i < tARGET_MAX_INT
319 = -- Start from an Int
320 StgPrimApp Int2IntegerOp [StgLitAtom (mkMachInt i)] bOGUS_LVs
323 = -- Start from a string
324 StgPrimApp Addr2IntegerOp [StgLitAtom (MachStr (_PK_ (show i)))] bOGUS_LVs
326 returnSUs (StgVarAtom var, unitBag (StgNonRec var rhs))
328 litToStgAtom (NoRepRational r)
329 = litToStgAtom (NoRepInteger (numerator r)) `thenSUs` \ (num_atom, binds1) ->
330 litToStgAtom (NoRepInteger (denominator r)) `thenSUs` \ (denom_atom, binds2) ->
331 newStgVar rationalTy `thenSUs` \ var ->
333 rhs = StgRhsCon noCostCentre -- No cost centre (ToDo?)
334 ratioDataCon -- Constructor
335 [num_atom, denom_atom]
337 returnSUs (StgVarAtom var, binds1 `unionBags`
339 unitBag (StgNonRec var rhs))
341 litToStgAtom other_lit = returnSUs (StgLitAtom other_lit, emptyBag)
345 %************************************************************************
347 \subsection[coreToStg-atoms{Converting atoms}
349 %************************************************************************
352 coreAtomToStg :: StgEnv -> PlainCoreAtom -> SUniqSM (PlainStgAtom, Bag PlainStgBinding)
354 coreAtomToStg env (CoVarAtom var) = returnSUs (stgLookup env var, emptyBag)
355 coreAtomToStg env (CoLitAtom lit) = litToStgAtom lit
358 There's not anything interesting we can ASSERT about \tr{var} if it
359 isn't in the StgEnv. (WDP 94/06)
361 stgLookup :: StgEnv -> Id -> PlainStgAtom
363 stgLookup env var = case (lookupIdEnv env var) of
364 Nothing -> StgVarAtom var
368 %************************************************************************
370 \subsection[coreToStg-exprs]{Converting core expressions}
372 %************************************************************************
375 coreExprToStg :: StgEnv
377 -> SUniqSM (PlainStgExpr, -- Result
378 Bag PlainStgBinding) -- Float these to top level
382 coreExprToStg env (CoLit lit)
383 = litToStgAtom lit `thenSUs` \ (atom, binds) ->
384 returnSUs (StgApp atom [] bOGUS_LVs, binds)
386 coreExprToStg env (CoVar var)
387 = returnSUs (StgApp (stgLookup env var) [] bOGUS_LVs, emptyBag)
389 coreExprToStg env (CoCon con types args)
390 = mapAndUnzipSUs (coreAtomToStg env) args `thenSUs` \ (stg_atoms, stg_binds) ->
391 returnSUs (StgConApp spec_con stg_atoms bOGUS_LVs, unionManyBags stg_binds)
393 spec_con = mkSpecialisedCon con types
395 coreExprToStg env (CoPrim op tys args)
396 = mapAndUnzipSUs (coreAtomToStg env) args `thenSUs` \ (stg_atoms, stg_binds) ->
397 returnSUs (StgPrimApp op stg_atoms bOGUS_LVs, unionManyBags stg_binds)
400 %************************************************************************
402 \subsubsection[coreToStg-type-stuff]{Type application and abstraction}
404 %************************************************************************
406 This type information dies in this Core-to-STG translation.
409 coreExprToStg env (CoTyLam tyvar expr) = coreExprToStg env expr
410 coreExprToStg env (CoTyApp expr ty) = coreExprToStg env expr
413 %************************************************************************
415 \subsubsection[coreToStg-lambdas]{Lambda abstractions}
417 %************************************************************************
420 coreExprToStg env expr@(CoLam binders body)
421 = coreExprToStg env body `thenSUs` \ (stg_body, binds) ->
422 newStgVar (typeOfCoreExpr expr) `thenSUs` \ var ->
423 returnSUs (StgLet (StgNonRec var (StgRhsClosure noCostCentre
426 ReEntrant -- binders is non-empty
429 (StgApp (StgVarAtom var) [] bOGUS_LVs),
433 %************************************************************************
435 \subsubsection[coreToStg-applications]{Applications}
437 %************************************************************************
440 coreExprToStg env expr@(CoApp _ _)
441 = -- Deal with the arguments
442 mapAndUnzipSUs (coreAtomToStg env) args `thenSUs` \ (stg_args, arg_binds) ->
444 -- Now deal with the function
446 CoVar fun_id -> returnSUs (StgApp (stgLookup env fun_id) stg_args bOGUS_LVs,
447 unionManyBags arg_binds)
449 other -> -- A non-variable applied to things; better let-bind it.
450 newStgVar (typeOfCoreExpr fun) `thenSUs` \ fun_id ->
451 coreExprToStg env fun `thenSUs` \ (stg_fun, fun_binds) ->
453 fun_rhs = StgRhsClosure noCostCentre -- No cost centre (ToDo?)
456 SingleEntry -- Only entered once
460 returnSUs (StgLet (StgNonRec fun_id fun_rhs)
461 (StgApp (StgVarAtom fun_id) stg_args bOGUS_LVs),
462 unionManyBags arg_binds `unionBags`
465 (fun,args) = collect_args expr []
467 -- Collect arguments, discarding type applications
468 collect_args (CoApp fun arg) args = collect_args fun (arg:args)
469 collect_args (CoTyApp e t) args = collect_args e args
470 collect_args fun args = (fun, args)
473 %************************************************************************
475 \subsubsection[coreToStg-cases]{Case expressions}
477 %************************************************************************
479 At this point, we *mangle* cases involving fork# and par# in the
480 discriminant. The original templates for these primops (see
481 @PrelVals.lhs@) constructed case expressions with boolean results
482 solely to fool the strictness analyzer, the simplifier, and anyone
483 else who might want to fool with the evaluation order. Now, we
484 believe that once the translation to STG code is performed, our
485 evaluation order is safe. Therefore, we convert expressions of the
499 coreExprToStg env (CoCase discrim@(CoPrim op tys args) alts)
500 | funnyParallelOp op =
501 getSUnique `thenSUs` \ uniq ->
502 coreExprToStg env discrim `thenSUs` \ (stg_discrim, discrim_binds) ->
503 alts_to_stg alts `thenSUs` \ (stg_alts, alts_binds) ->
510 discrim_binds `unionBags` alts_binds
513 funnyParallelOp SeqOp = True
514 funnyParallelOp ParOp = True
515 funnyParallelOp ForkOp = True
516 funnyParallelOp _ = False
518 discrim_ty = typeOfCoreExpr discrim
520 alts_to_stg (CoPrimAlts _ (CoBindDefault binder rhs))
521 = coreExprToStg env rhs `thenSUs` \ (stg_rhs, rhs_binds) ->
523 stg_deflt = StgBindDefault binder False stg_rhs
525 returnSUs (StgPrimAlts discrim_ty [] stg_deflt, rhs_binds)
527 -- OK, back to real life...
529 coreExprToStg env (CoCase discrim alts)
530 = coreExprToStg env discrim `thenSUs` \ (stg_discrim, discrim_binds) ->
531 alts_to_stg discrim alts `thenSUs` \ (stg_alts, alts_binds) ->
532 getSUnique `thenSUs` \ uniq ->
539 discrim_binds `unionBags` alts_binds
542 discrim_ty = typeOfCoreExpr discrim
543 (_, discrim_ty_args, _) = getUniDataTyCon discrim_ty
545 alts_to_stg discrim (CoAlgAlts alts deflt)
546 = default_to_stg discrim deflt `thenSUs` \ (stg_deflt, deflt_binds) ->
547 mapAndUnzipSUs boxed_alt_to_stg alts `thenSUs` \ (stg_alts, alts_binds) ->
548 returnSUs (StgAlgAlts discrim_ty stg_alts stg_deflt,
549 deflt_binds `unionBags` unionManyBags alts_binds)
551 boxed_alt_to_stg (con, bs, rhs)
552 = coreExprToStg env rhs `thenSUs` \ (stg_rhs, rhs_binds) ->
553 returnSUs ((spec_con, bs, [ True | b <- bs ]{-bogus use mask-}, stg_rhs),
556 spec_con = mkSpecialisedCon con discrim_ty_args
558 alts_to_stg discrim (CoPrimAlts alts deflt)
559 = default_to_stg discrim deflt `thenSUs` \ (stg_deflt,deflt_binds) ->
560 mapAndUnzipSUs unboxed_alt_to_stg alts `thenSUs` \ (stg_alts, alts_binds) ->
561 returnSUs (StgPrimAlts discrim_ty stg_alts stg_deflt,
562 deflt_binds `unionBags` unionManyBags alts_binds)
564 unboxed_alt_to_stg (lit, rhs)
565 = coreExprToStg env rhs `thenSUs` \ (stg_rhs, rhs_binds) ->
566 returnSUs ((lit, stg_rhs), rhs_binds)
569 alts_to_stg (CoParAlgAlts tycon ctxt params alts deflt)
570 = default_to_stg deflt `thenSUs` \ stg_deflt ->
571 mapSUs boxed_alt_to_stg alts `thenSUs` \ stg_alts ->
572 returnSUs (StgParAlgAlts discrim_ty ctxt params stg_alts stg_deflt)
574 boxed_alt_to_stg (con, rhs)
575 = coreExprToStg env rhs `thenSUs` \ stg_rhs ->
576 returnSUs (con, stg_rhs)
578 alts_to_stg (CoParPrimAlts tycon ctxt alts deflt)
579 = default_to_stg deflt `thenSUs` \ stg_deflt ->
580 mapSUs unboxed_alt_to_stg alts `thenSUs` \ stg_alts ->
581 returnSUs (StgParPrimAlts discrim_ty ctxt stg_alts stg_deflt)
583 unboxed_alt_to_stg (lit, rhs)
584 = coreExprToStg env rhs `thenSUs` \ stg_rhs ->
585 returnSUs (lit, stg_rhs)
586 #endif {- Data Parallel Haskell -}
588 default_to_stg discrim CoNoDefault
589 = returnSUs (StgNoDefault, emptyBag)
591 default_to_stg discrim (CoBindDefault binder rhs)
592 = coreExprToStg new_env rhs `thenSUs` \ (stg_rhs, rhs_binds) ->
593 returnSUs (StgBindDefault binder True{-used? no it is lying-} stg_rhs,
598 -- We convert case x of {...; x' -> ...x'...}
600 -- case x of {...; _ -> ...x... }
602 -- See notes in SimplCase.lhs, near simplDefault for the reasoning.
603 -- It's quite easily done: simply extend the environment to bind the
604 -- default binder to the scrutinee.
606 new_env = case discrim of
607 CoVar v -> addOneToIdEnv env binder (StgVarAtom v)
611 %************************************************************************
613 \subsubsection[coreToStg-let(rec)]{Let and letrec expressions}
615 %************************************************************************
618 coreExprToStg env (CoLet bind body)
619 = coreBindToStg env bind `thenSUs` \ (stg_binds, new_env, float_binds1) ->
620 coreExprToStg new_env body `thenSUs` \ (stg_body, float_binds2) ->
621 returnSUs (mkStgLets stg_binds stg_body, float_binds1 `unionBags` float_binds2)
625 %************************************************************************
627 \subsubsection[coreToStg-scc]{SCC expressions}
629 %************************************************************************
631 Covert core @scc@ expression directly to STG @scc@ expression.
633 coreExprToStg env (CoSCC cc expr)
634 = coreExprToStg env expr `thenSUs` \ (stg_expr, binds) ->
635 returnSUs (StgSCC (typeOfCoreExpr expr) cc stg_expr, binds)
638 %************************************************************************
640 \subsubsection[coreToStg-dataParallel]{Data Parallel expressions}
642 %************************************************************************
645 coreExprToStg env (_, AnnCoParCon con ctxt types args)
646 = mapAndUnzipSUs (arg2stg env) args `thenSUs` \ (stg_atoms, stg_binds) ->
647 returnSUs (mkStgLets (catMaybes stg_binds)
648 (StgParConApp con ctxt stg_atoms bOGUS_LVs))
650 coreExprToStg env (_,AnnCoParComm ctxt expr comm)
651 = coreExprToStg env expr `thenSUs` \ stg_expr ->
652 annComm_to_stg comm `thenSUs` \ (stg_comm,stg_binds) ->
653 returnSUs (mkStgLets (catMaybes stg_binds)
654 (StgParComm ctxt stg_expr stg_comm))
657 annComm_to_stg (AnnCoParSend args)
658 = mapAndUnzipSUs (arg2stg env) args `thenSUs` \ (stg_atoms, stg_binds) ->
659 returnSUs (StgParSend stg_atoms,stg_binds)
661 annComm_to_stg (AnnCoParFetch args)
662 = mapAndUnzipSUs (arg2stg env) args `thenSUs` \ (stg_atoms, stg_binds) ->
663 returnSUs (StgParFetch stg_atoms,stg_binds)
665 annComm_to_stg (AnnCoToPodized)
666 = returnSUs (StgToPodized,[])
667 annComm_to_stg (AnnCoFromPodized)
668 = returnSUs (StgFromPodized,[])
669 #endif {- Data Parallel Haskell -}
673 coreExprToStg env other = panic "coreExprToStg: it really failed here"
676 %************************************************************************
678 \subsection[coreToStg-misc]{Miscellaneous helping functions}
680 %************************************************************************
686 newStgVar :: UniType -> SUniqSM Id
688 = getSUnique `thenSUs` \ uniq ->
689 returnSUs (mkSysLocal SLIT("stg") uniq ty mkUnknownSrcLoc)
693 mkStgLets :: [PlainStgBinding]
694 -> PlainStgExpr -- body of let
697 mkStgLets binds body = foldr StgLet body binds