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, 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" -- emptyUniqSet (used when pprTracing)
103 bOGUS_FVs = panic "bOGUS_FVs" -- [] (ditto)
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 ppr_blah xs = ppInterleave ppComma (map pp_x xs)
133 pp_x (u,x) = ppBesides [pprUnique u, ppStr ": ", ppr PprDebug x]
135 pprTrace "do_top_bind:" (ppAbove (ppr PprDebug stg_binds) (ppr_blah (ufmToList new_env))) $
138 [StgNonRec var (StgRhsClosure cc bi fvs u [] rhs_body)] ->
139 -- Mega-special case; there's still a binding there
140 -- no fvs (of course), *no args*, "let" rhs
142 (extra_float_binds, rhs_body') = seek_liftable [] rhs_body
144 returnSUs (extra_float_binds ++
145 [StgNonRec var (StgRhsClosure cc bi fvs u [] rhs_body')],
149 other -> returnSUs (stg_binds, new_env, float_binds)
152 -- HACK: look for very simple, obviously-liftable bindings
153 -- that can come up to the top level; those that couldn't
154 -- 'cause they were big-lambda constrained in the Core world.
156 seek_liftable :: [PlainStgBinding] -- accumulator...
157 -> PlainStgExpr -- look for top-lev liftables
158 -> ([PlainStgBinding], PlainStgExpr) -- result
160 seek_liftable acc expr@(StgLet inner_bind body)
161 | is_liftable inner_bind
162 = seek_liftable (inner_bind : acc) body
164 seek_liftable acc other_expr = (reverse acc, other_expr) -- Finished
167 is_liftable (StgNonRec binder (StgRhsClosure _ _ _ _ args body))
168 = not (null args) -- it's manifestly a function...
169 || isLeakFreeType [] (getIdUniType binder)
171 -- ToDo: use a decent manifestlyWHNF function for STG?
173 is_whnf (StgConApp _ _ _) = True
174 is_whnf (StgApp (StgVarAtom v) _ _) = isBottomingId v
175 is_whnf other = False
177 is_liftable (StgRec [(_, StgRhsClosure _ _ _ _ args body)])
178 = not (null args) -- it's manifestly a (recursive) function...
180 is_liftable anything_else = False
183 %************************************************************************
185 \subsection[coreToStg-binds]{Converting bindings}
187 %************************************************************************
190 coreBindToStg :: StgEnv
192 -> SUniqSM ([PlainStgBinding], -- Empty or singleton
194 Bag PlainStgBinding) -- Floats
196 coreBindToStg env (CoNonRec binder rhs)
197 = coreRhsToStg env rhs `thenSUs` \ (stg_rhs, rhs_binds) ->
200 -- Binds to return if RHS is trivial
201 triv_binds = if isExported binder then
202 [StgNonRec binder stg_rhs] -- Retain it
207 StgRhsClosure cc bi fvs upd [] (StgApp atom [] lvs) ->
208 -- Trivial RHS, so augment envt, and ditch the binding
209 returnSUs (triv_binds, new_env, rhs_binds)
211 new_env = addOneToIdEnv env binder atom
213 StgRhsCon cc con_id [] ->
214 -- Trivial RHS, so augment envt, and ditch the binding
215 returnSUs (triv_binds, new_env, rhs_binds)
217 new_env = addOneToIdEnv env binder (StgVarAtom con_id)
219 other -> -- Non-trivial RHS, so don't augment envt
220 returnSUs ([StgNonRec binder stg_rhs], env, rhs_binds)
222 coreBindToStg env (CoRec pairs)
223 = -- NB: *** WE DO NOT CHECK FOR TRIV_BINDS in REC BIND ****
226 (binders, rhss) = unzip pairs
228 mapAndUnzipSUs (coreRhsToStg env) rhss `thenSUs` \ (stg_rhss, rhs_binds) ->
229 returnSUs ([StgRec (binders `zip` stg_rhss)], env, unionManyBags rhs_binds)
233 %************************************************************************
235 \subsection[coreToStg-rhss]{Converting right hand sides}
237 %************************************************************************
240 coreRhsToStg :: StgEnv -> PlainCoreExpr -> SUniqSM (PlainStgRhs, Bag PlainStgBinding)
242 coreRhsToStg env core_rhs
243 = coreExprToStg env core_rhs `thenSUs` \ (stg_expr, stg_binds) ->
245 let stg_rhs = case stg_expr of
246 StgLet (StgNonRec var1 rhs) (StgApp (StgVarAtom var2) [] _)
247 | var1 == var2 -> rhs
248 -- This curious stuff is to unravel what a lambda turns into
249 -- We have to do it this way, rather than spot a lambda in the
252 StgConApp con args _ -> StgRhsCon noCostCentre con args
254 other -> StgRhsClosure noCostCentre -- No cost centre (ToDo?)
257 Updatable -- Be pessimistic
261 returnSUs (stg_rhs, stg_binds)
265 %************************************************************************
267 \subsection[coreToStg-lits]{Converting literals}
269 %************************************************************************
271 Literals: the NoRep kind need to be de-no-rep'd.
272 We always replace them with a simple variable, and float a suitable
273 binding out to the top level.
275 If an Integer is small enough (Haskell implementations must support
276 Ints in the range $[-2^29+1, 2^29-1]$), wrap it up in @int2Integer@;
277 otherwise, wrap with @litString2Integer@.
280 tARGET_MIN_INT, tARGET_MAX_INT :: Integer
281 tARGET_MIN_INT = -536870912
282 tARGET_MAX_INT = 536870912
284 litToStgAtom :: BasicLit -> SUniqSM (PlainStgAtom, Bag PlainStgBinding)
286 litToStgAtom (NoRepStr s)
287 = newStgVar stringTy `thenSUs` \ var ->
289 rhs = StgRhsClosure noCostCentre -- No cost centre (ToDo?)
292 Updatable -- OLD: ReEntrant (see note below)
296 -- We used not to update strings, so that they wouldn't clog up the heap,
297 -- but instead be unpacked each time. But on some programs that costs a lot
298 -- [eg hpg], so now we update them.
300 val = if (any is_NUL (_UNPK_ s)) then -- must cater for NULs in literal string
301 StgApp (StgVarAtom unpackCString2Id)
302 [StgLitAtom (MachStr s),
303 StgLitAtom (mkMachInt (toInteger (_LENGTH_ s)))]
306 StgApp (StgVarAtom unpackCStringId)
307 [StgLitAtom (MachStr s)]
310 returnSUs (StgVarAtom var, unitBag (StgNonRec var rhs))
314 litToStgAtom (NoRepInteger i)
315 -- extremely convenient to look out for a few very common
317 | i == 0 = returnSUs (StgVarAtom integerZeroId, emptyBag)
318 | i == 1 = returnSUs (StgVarAtom integerPlusOneId, emptyBag)
319 | i == (-1) = returnSUs (StgVarAtom integerMinusOneId, emptyBag)
322 = newStgVar integerTy `thenSUs` \ 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 StgPrimApp Int2IntegerOp [StgLitAtom (mkMachInt i)] bOGUS_LVs
337 = -- Start from a string
338 StgPrimApp Addr2IntegerOp [StgLitAtom (MachStr (_PK_ (show i)))] bOGUS_LVs
340 returnSUs (StgVarAtom var, unitBag (StgNonRec var rhs))
342 litToStgAtom (NoRepRational r)
343 = litToStgAtom (NoRepInteger (numerator r)) `thenSUs` \ (num_atom, binds1) ->
344 litToStgAtom (NoRepInteger (denominator r)) `thenSUs` \ (denom_atom, binds2) ->
345 newStgVar rationalTy `thenSUs` \ var ->
347 rhs = StgRhsCon noCostCentre -- No cost centre (ToDo?)
348 ratioDataCon -- Constructor
349 [num_atom, denom_atom]
351 returnSUs (StgVarAtom var, binds1 `unionBags`
353 unitBag (StgNonRec var rhs))
355 litToStgAtom other_lit = returnSUs (StgLitAtom other_lit, emptyBag)
359 %************************************************************************
361 \subsection[coreToStg-atoms{Converting atoms}
363 %************************************************************************
366 coreAtomToStg :: StgEnv -> PlainCoreAtom -> SUniqSM (PlainStgAtom, Bag PlainStgBinding)
368 coreAtomToStg env (CoVarAtom var) = returnSUs (stgLookup env var, emptyBag)
369 coreAtomToStg env (CoLitAtom lit) = litToStgAtom lit
372 There's not anything interesting we can ASSERT about \tr{var} if it
373 isn't in the StgEnv. (WDP 94/06)
375 stgLookup :: StgEnv -> Id -> PlainStgAtom
377 stgLookup env var = case (lookupIdEnv env var) of
378 Nothing -> StgVarAtom var
382 %************************************************************************
384 \subsection[coreToStg-exprs]{Converting core expressions}
386 %************************************************************************
389 coreExprToStg :: StgEnv
391 -> SUniqSM (PlainStgExpr, -- Result
392 Bag PlainStgBinding) -- Float these to top level
396 coreExprToStg env (CoLit lit)
397 = litToStgAtom lit `thenSUs` \ (atom, binds) ->
398 returnSUs (StgApp atom [] bOGUS_LVs, binds)
400 coreExprToStg env (CoVar var)
401 = returnSUs (StgApp (stgLookup env var) [] bOGUS_LVs, emptyBag)
403 coreExprToStg env (CoCon con types args)
404 = mapAndUnzipSUs (coreAtomToStg env) args `thenSUs` \ (stg_atoms, stg_binds) ->
405 returnSUs (StgConApp spec_con stg_atoms bOGUS_LVs, unionManyBags stg_binds)
407 spec_con = mkSpecialisedCon con types
409 coreExprToStg env (CoPrim op tys args)
410 = mapAndUnzipSUs (coreAtomToStg env) args `thenSUs` \ (stg_atoms, stg_binds) ->
411 returnSUs (StgPrimApp op stg_atoms bOGUS_LVs, unionManyBags stg_binds)
414 %************************************************************************
416 \subsubsection[coreToStg-type-stuff]{Type application and abstraction}
418 %************************************************************************
420 This type information dies in this Core-to-STG translation.
423 coreExprToStg env (CoTyLam tyvar expr) = coreExprToStg env expr
424 coreExprToStg env (CoTyApp expr ty) = coreExprToStg env expr
427 %************************************************************************
429 \subsubsection[coreToStg-lambdas]{Lambda abstractions}
431 %************************************************************************
434 coreExprToStg env expr@(CoLam binders body)
435 = coreExprToStg env body `thenSUs` \ (stg_body, binds) ->
436 newStgVar (typeOfCoreExpr expr) `thenSUs` \ var ->
437 returnSUs (StgLet (StgNonRec var (StgRhsClosure noCostCentre
440 ReEntrant -- binders is non-empty
443 (StgApp (StgVarAtom var) [] bOGUS_LVs),
447 %************************************************************************
449 \subsubsection[coreToStg-applications]{Applications}
451 %************************************************************************
454 coreExprToStg env expr@(CoApp _ _)
455 = -- Deal with the arguments
456 mapAndUnzipSUs (coreAtomToStg env) args `thenSUs` \ (stg_args, arg_binds) ->
458 -- Now deal with the function
460 CoVar fun_id -> returnSUs (StgApp (stgLookup env fun_id) stg_args bOGUS_LVs,
461 unionManyBags arg_binds)
463 other -> -- A non-variable applied to things; better let-bind it.
464 newStgVar (typeOfCoreExpr fun) `thenSUs` \ fun_id ->
465 coreExprToStg env fun `thenSUs` \ (stg_fun, fun_binds) ->
467 fun_rhs = StgRhsClosure noCostCentre -- No cost centre (ToDo?)
470 SingleEntry -- Only entered once
474 returnSUs (StgLet (StgNonRec fun_id fun_rhs)
475 (StgApp (StgVarAtom fun_id) stg_args bOGUS_LVs),
476 unionManyBags arg_binds `unionBags`
479 (fun,args) = collect_args expr []
481 -- Collect arguments, discarding type applications
482 collect_args (CoApp fun arg) args = collect_args fun (arg:args)
483 collect_args (CoTyApp e t) args = collect_args e args
484 collect_args fun args = (fun, args)
487 %************************************************************************
489 \subsubsection[coreToStg-cases]{Case expressions}
491 %************************************************************************
493 At this point, we *mangle* cases involving fork# and par# in the
494 discriminant. The original templates for these primops (see
495 @PrelVals.lhs@) constructed case expressions with boolean results
496 solely to fool the strictness analyzer, the simplifier, and anyone
497 else who might want to fool with the evaluation order. Now, we
498 believe that once the translation to STG code is performed, our
499 evaluation order is safe. Therefore, we convert expressions of the
513 coreExprToStg env (CoCase discrim@(CoPrim op tys args) alts)
514 | funnyParallelOp op =
515 getSUnique `thenSUs` \ uniq ->
516 coreExprToStg env discrim `thenSUs` \ (stg_discrim, discrim_binds) ->
517 alts_to_stg alts `thenSUs` \ (stg_alts, alts_binds) ->
524 discrim_binds `unionBags` alts_binds
527 funnyParallelOp SeqOp = True
528 funnyParallelOp ParOp = True
529 funnyParallelOp ForkOp = True
530 funnyParallelOp _ = False
532 discrim_ty = typeOfCoreExpr discrim
534 alts_to_stg (CoPrimAlts _ (CoBindDefault binder rhs))
535 = coreExprToStg env rhs `thenSUs` \ (stg_rhs, rhs_binds) ->
537 stg_deflt = StgBindDefault binder False stg_rhs
539 returnSUs (StgPrimAlts discrim_ty [] stg_deflt, rhs_binds)
541 -- OK, back to real life...
543 coreExprToStg env (CoCase discrim alts)
544 = coreExprToStg env discrim `thenSUs` \ (stg_discrim, discrim_binds) ->
545 alts_to_stg discrim alts `thenSUs` \ (stg_alts, alts_binds) ->
546 getSUnique `thenSUs` \ uniq ->
553 discrim_binds `unionBags` alts_binds
556 discrim_ty = typeOfCoreExpr discrim
557 (_, discrim_ty_args, _) = getUniDataTyCon discrim_ty
559 alts_to_stg discrim (CoAlgAlts alts deflt)
560 = default_to_stg discrim deflt `thenSUs` \ (stg_deflt, deflt_binds) ->
561 mapAndUnzipSUs boxed_alt_to_stg alts `thenSUs` \ (stg_alts, alts_binds) ->
562 returnSUs (StgAlgAlts discrim_ty stg_alts stg_deflt,
563 deflt_binds `unionBags` unionManyBags alts_binds)
565 boxed_alt_to_stg (con, bs, rhs)
566 = coreExprToStg env rhs `thenSUs` \ (stg_rhs, rhs_binds) ->
567 returnSUs ((spec_con, bs, [ True | b <- bs ]{-bogus use mask-}, stg_rhs),
570 spec_con = mkSpecialisedCon con discrim_ty_args
572 alts_to_stg discrim (CoPrimAlts alts deflt)
573 = default_to_stg discrim deflt `thenSUs` \ (stg_deflt,deflt_binds) ->
574 mapAndUnzipSUs unboxed_alt_to_stg alts `thenSUs` \ (stg_alts, alts_binds) ->
575 returnSUs (StgPrimAlts discrim_ty stg_alts stg_deflt,
576 deflt_binds `unionBags` unionManyBags alts_binds)
578 unboxed_alt_to_stg (lit, rhs)
579 = coreExprToStg env rhs `thenSUs` \ (stg_rhs, rhs_binds) ->
580 returnSUs ((lit, stg_rhs), rhs_binds)
583 alts_to_stg (CoParAlgAlts tycon ctxt params alts deflt)
584 = default_to_stg deflt `thenSUs` \ stg_deflt ->
585 mapSUs boxed_alt_to_stg alts `thenSUs` \ stg_alts ->
586 returnSUs (StgParAlgAlts discrim_ty ctxt params stg_alts stg_deflt)
588 boxed_alt_to_stg (con, rhs)
589 = coreExprToStg env rhs `thenSUs` \ stg_rhs ->
590 returnSUs (con, stg_rhs)
592 alts_to_stg (CoParPrimAlts tycon ctxt alts deflt)
593 = default_to_stg deflt `thenSUs` \ stg_deflt ->
594 mapSUs unboxed_alt_to_stg alts `thenSUs` \ stg_alts ->
595 returnSUs (StgParPrimAlts discrim_ty ctxt stg_alts stg_deflt)
597 unboxed_alt_to_stg (lit, rhs)
598 = coreExprToStg env rhs `thenSUs` \ stg_rhs ->
599 returnSUs (lit, stg_rhs)
600 #endif {- Data Parallel Haskell -}
602 default_to_stg discrim CoNoDefault
603 = returnSUs (StgNoDefault, emptyBag)
605 default_to_stg discrim (CoBindDefault binder rhs)
606 = coreExprToStg new_env rhs `thenSUs` \ (stg_rhs, rhs_binds) ->
607 returnSUs (StgBindDefault binder True{-used? no it is lying-} stg_rhs,
611 -- We convert case x of {...; x' -> ...x'...}
613 -- case x of {...; _ -> ...x... }
615 -- See notes in SimplCase.lhs, near simplDefault for the reasoning.
616 -- It's quite easily done: simply extend the environment to bind the
617 -- default binder to the scrutinee.
619 new_env = case discrim of
620 CoVar v -> addOneToIdEnv env binder (stgLookup env v)
624 %************************************************************************
626 \subsubsection[coreToStg-let(rec)]{Let and letrec expressions}
628 %************************************************************************
631 coreExprToStg env (CoLet bind body)
632 = coreBindToStg env bind `thenSUs` \ (stg_binds, new_env, float_binds1) ->
633 coreExprToStg new_env body `thenSUs` \ (stg_body, float_binds2) ->
634 returnSUs (mkStgLets stg_binds stg_body, float_binds1 `unionBags` float_binds2)
638 %************************************************************************
640 \subsubsection[coreToStg-scc]{SCC expressions}
642 %************************************************************************
644 Covert core @scc@ expression directly to STG @scc@ expression.
646 coreExprToStg env (CoSCC cc expr)
647 = coreExprToStg env expr `thenSUs` \ (stg_expr, binds) ->
648 returnSUs (StgSCC (typeOfCoreExpr expr) cc stg_expr, binds)
651 %************************************************************************
653 \subsubsection[coreToStg-dataParallel]{Data Parallel expressions}
655 %************************************************************************
658 coreExprToStg env (_, AnnCoParCon con ctxt types args)
659 = mapAndUnzipSUs (arg2stg env) args `thenSUs` \ (stg_atoms, stg_binds) ->
660 returnSUs (mkStgLets (catMaybes stg_binds)
661 (StgParConApp con ctxt stg_atoms bOGUS_LVs))
663 coreExprToStg env (_,AnnCoParComm ctxt expr comm)
664 = coreExprToStg env expr `thenSUs` \ stg_expr ->
665 annComm_to_stg comm `thenSUs` \ (stg_comm,stg_binds) ->
666 returnSUs (mkStgLets (catMaybes stg_binds)
667 (StgParComm ctxt stg_expr stg_comm))
670 annComm_to_stg (AnnCoParSend args)
671 = mapAndUnzipSUs (arg2stg env) args `thenSUs` \ (stg_atoms, stg_binds) ->
672 returnSUs (StgParSend stg_atoms,stg_binds)
674 annComm_to_stg (AnnCoParFetch args)
675 = mapAndUnzipSUs (arg2stg env) args `thenSUs` \ (stg_atoms, stg_binds) ->
676 returnSUs (StgParFetch stg_atoms,stg_binds)
678 annComm_to_stg (AnnCoToPodized)
679 = returnSUs (StgToPodized,[])
680 annComm_to_stg (AnnCoFromPodized)
681 = returnSUs (StgFromPodized,[])
682 #endif {- Data Parallel Haskell -}
687 coreExprToStg env other = panic "coreExprToStg: it really failed here"
691 %************************************************************************
693 \subsection[coreToStg-misc]{Miscellaneous helping functions}
695 %************************************************************************
701 newStgVar :: UniType -> SUniqSM Id
703 = getSUnique `thenSUs` \ uniq ->
704 returnSUs (mkSysLocal SLIT("stg") uniq ty mkUnknownSrcLoc)
708 mkStgLets :: [PlainStgBinding]
709 -> PlainStgExpr -- body of let
712 mkStgLets binds body = foldr StgLet body binds