Snapshot of codegen refactoring to share with simonpj
[ghc.git] / compiler / codeGen / StgCmmExpr.hs
1 -----------------------------------------------------------------------------
2 --
3 -- Stg to C-- code generation: expressions
4 --
5 -- (c) The University of Glasgow 2004-2006
6 --
7 -----------------------------------------------------------------------------
8
9 module StgCmmExpr ( cgExpr ) where
10
11 #define FAST_STRING_NOT_NEEDED
12 #include "HsVersions.h"
13
14 import {-# SOURCE #-} StgCmmBind ( cgBind )
15
16 import StgCmmMonad
17 import StgCmmHeap
18 import StgCmmEnv
19 import StgCmmCon
20 import StgCmmProf
21 import StgCmmLayout
22 import StgCmmPrim
23 import StgCmmHpc
24 import StgCmmTicky
25 import StgCmmUtils
26 import StgCmmClosure
27
28 import StgSyn
29
30 import MkGraph
31 import BlockId
32 import Cmm
33 import CoreSyn
34 import DataCon
35 import ForeignCall
36 import Id
37 import PrimOp
38 import SMRep
39 import TyCon
40 import Type
41 import CostCentre ( CostCentreStack, currentCCS )
42 import Control.Monad (when)
43 import Maybes
44 import Util
45 import FastString
46 import Outputable
47 import UniqSupply
48
49 ------------------------------------------------------------------------
50 -- cgExpr: the main function
51 ------------------------------------------------------------------------
52
53 cgExpr :: StgExpr -> FCode ()
54
55 cgExpr (StgApp fun args) = cgIdApp fun args
56
57 {- seq# a s ==> a -}
58 cgExpr (StgOpApp (StgPrimOp SeqOp) [StgVarArg a, _] _res_ty) =
59 cgIdApp a []
60
61 cgExpr (StgOpApp op args ty) = cgOpApp op args ty
62 cgExpr (StgConApp con args) = cgConApp con args
63 cgExpr (StgSCC cc expr) = do { emitSetCCC cc; cgExpr expr }
64 cgExpr (StgTick m n expr) = do { emit (mkTickBox m n); cgExpr expr }
65 cgExpr (StgLit lit) = do cmm_lit <- cgLit lit
66 emitReturn [CmmLit cmm_lit]
67
68 cgExpr (StgLet binds expr) = do { cgBind binds; cgExpr expr }
69 cgExpr (StgLetNoEscape _ _ binds expr) =
70 do { us <- newUniqSupply
71 ; let join_id = mkBlockId (uniqFromSupply us)
72 ; cgLneBinds join_id binds
73 ; cgExpr expr
74 ; emit $ mkLabel join_id}
75
76 cgExpr (StgCase expr _live_vars _save_vars bndr srt alt_type alts) =
77 cgCase expr bndr srt alt_type alts
78
79 cgExpr (StgLam {}) = panic "cgExpr: StgLam"
80
81 ------------------------------------------------------------------------
82 -- Let no escape
83 ------------------------------------------------------------------------
84
85 {- Generating code for a let-no-escape binding, aka join point is very
86 very similar to what we do for a case expression. The duality is
87 between
88 let-no-escape x = b
89 in e
90 and
91 case e of ... -> b
92
93 That is, the RHS of 'x' (ie 'b') will execute *later*, just like
94 the alternative of the case; it needs to be compiled in an environment
95 in which all volatile bindings are forgotten, and the free vars are
96 bound only to stable things like stack locations.. The 'e' part will
97 execute *next*, just like the scrutinee of a case. -}
98
99 -------------------------
100 cgLneBinds :: BlockId -> StgBinding -> FCode ()
101 cgLneBinds join_id (StgNonRec bndr rhs)
102 = do { local_cc <- saveCurrentCostCentre
103 -- See Note [Saving the current cost centre]
104 ; info <- cgLetNoEscapeRhs join_id local_cc bndr rhs
105 ; addBindC (cg_id info) info }
106
107 cgLneBinds join_id (StgRec pairs)
108 = do { local_cc <- saveCurrentCostCentre
109 ; new_bindings <- fixC (\ new_bindings -> do
110 { addBindsC new_bindings
111 ; listFCs [ cgLetNoEscapeRhs join_id local_cc b e
112 | (b,e) <- pairs ] })
113 ; addBindsC new_bindings }
114
115
116 -------------------------
117 cgLetNoEscapeRhs
118 :: BlockId -- join point for successor of let-no-escape
119 -> Maybe LocalReg -- Saved cost centre
120 -> Id
121 -> StgRhs
122 -> FCode CgIdInfo
123
124 cgLetNoEscapeRhs join_id local_cc bndr rhs =
125 do { (info, rhs_body) <- getCodeR $ cgLetNoEscapeRhsBody local_cc bndr rhs
126 ; let (bid, _) = expectJust "cgLetNoEscapeRhs" $ maybeLetNoEscape info
127 ; emit (outOfLine $ mkLabel bid <*> rhs_body <*> mkBranch join_id)
128 ; return info
129 }
130
131 cgLetNoEscapeRhsBody
132 :: Maybe LocalReg -- Saved cost centre
133 -> Id
134 -> StgRhs
135 -> FCode CgIdInfo
136 cgLetNoEscapeRhsBody local_cc bndr (StgRhsClosure cc _bi _ _upd _ args body)
137 = cgLetNoEscapeClosure bndr local_cc cc (nonVoidIds args) body
138 cgLetNoEscapeRhsBody local_cc bndr (StgRhsCon cc con args)
139 = cgLetNoEscapeClosure bndr local_cc cc [] (StgConApp con args)
140 -- For a constructor RHS we want to generate a single chunk of
141 -- code which can be jumped to from many places, which will
142 -- return the constructor. It's easy; just behave as if it
143 -- was an StgRhsClosure with a ConApp inside!
144
145 -------------------------
146 cgLetNoEscapeClosure
147 :: Id -- binder
148 -> Maybe LocalReg -- Slot for saved current cost centre
149 -> CostCentreStack -- XXX: *** NOT USED *** why not?
150 -> [NonVoid Id] -- Args (as in \ args -> body)
151 -> StgExpr -- Body (as in above)
152 -> FCode CgIdInfo
153
154 cgLetNoEscapeClosure bndr cc_slot _unused_cc args body
155 = do { arg_regs <- forkProc $ do
156 { restoreCurrentCostCentre cc_slot
157 ; arg_regs <- bindArgsToRegs args
158 ; altHeapCheck arg_regs (cgExpr body)
159 -- Using altHeapCheck just reduces
160 -- instructions to save on stack
161 ; return arg_regs }
162 ; return $ lneIdInfo bndr arg_regs}
163
164
165 ------------------------------------------------------------------------
166 -- Case expressions
167 ------------------------------------------------------------------------
168
169 {- Note [Compiling case expressions]
170 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
171 It is quite interesting to decide whether to put a heap-check at the
172 start of each alternative. Of course we certainly have to do so if
173 the case forces an evaluation, or if there is a primitive op which can
174 trigger GC.
175
176 A more interesting situation is this (a Plan-B situation)
177
178 !P!;
179 ...P...
180 case x# of
181 0# -> !Q!; ...Q...
182 default -> !R!; ...R...
183
184 where !x! indicates a possible heap-check point. The heap checks
185 in the alternatives *can* be omitted, in which case the topmost
186 heapcheck will take their worst case into account.
187
188 In favour of omitting !Q!, !R!:
189
190 - *May* save a heap overflow test,
191 if ...P... allocates anything.
192
193 - We can use relative addressing from a single Hp to
194 get at all the closures so allocated.
195
196 - No need to save volatile vars etc across heap checks
197 in !Q!, !R!
198
199 Against omitting !Q!, !R!
200
201 - May put a heap-check into the inner loop. Suppose
202 the main loop is P -> R -> P -> R...
203 Q is the loop exit, and only it does allocation.
204 This only hurts us if P does no allocation. If P allocates,
205 then there is a heap check in the inner loop anyway.
206
207 - May do more allocation than reqd. This sometimes bites us
208 badly. For example, nfib (ha!) allocates about 30\% more space if the
209 worst-casing is done, because many many calls to nfib are leaf calls
210 which don't need to allocate anything.
211
212 We can un-allocate, but that costs an instruction
213
214 Neither problem hurts us if there is only one alternative.
215
216 Suppose the inner loop is P->R->P->R etc. Then here is
217 how many heap checks we get in the *inner loop* under various
218 conditions
219
220 Alooc Heap check in branches (!Q!, !R!)?
221 P Q R yes no (absorb to !P!)
222 --------------------------------------
223 n n n 0 0
224 n y n 0 1
225 n . y 1 1
226 y . y 2 1
227 y . n 1 1
228
229 Best choices: absorb heap checks from Q and R into !P! iff
230 a) P itself does some allocation
231 or
232 b) P does allocation, or there is exactly one alternative
233
234 We adopt (b) because that is more likely to put the heap check at the
235 entry to a function, when not many things are live. After a bunch of
236 single-branch cases, we may have lots of things live
237
238 Hence: two basic plans for
239
240 case e of r { alts }
241
242 ------ Plan A: the general case ---------
243
244 ...save current cost centre...
245
246 ...code for e,
247 with sequel (SetLocals r)
248
249 ...restore current cost centre...
250 ...code for alts...
251 ...alts do their own heap checks
252
253 ------ Plan B: special case when ---------
254 (i) e does not allocate or call GC
255 (ii) either upstream code performs allocation
256 or there is just one alternative
257
258 Then heap allocation in the (single) case branch
259 is absorbed by the upstream check.
260 Very common example: primops on unboxed values
261
262 ...code for e,
263 with sequel (SetLocals r)...
264
265 ...code for alts...
266 ...no heap check...
267 -}
268
269
270
271 -------------------------------------
272 data GcPlan
273 = GcInAlts -- Put a GC check at the start the case alternatives,
274 [LocalReg] -- which binds these registers
275 SRT -- using this SRT
276 | NoGcInAlts -- The scrutinee is a primitive value, or a call to a
277 -- primitive op which does no GC. Absorb the allocation
278 -- of the case alternative(s) into the upstream check
279
280 -------------------------------------
281 -- See Note [case on Bool]
282 cgCase :: StgExpr -> Id -> SRT -> AltType -> [StgAlt] -> FCode ()
283 {-
284 cgCase (OpApp ) bndr srt AlgAlt [(DataAlt flase, a2]
285 | isBoolTy (idType bndr)
286 , isDeadBndr bndr
287 =
288 -}
289
290 -- Note [ticket #3132]: we might be looking at a case of a lifted Id
291 -- that was cast to an unlifted type. The Id will always be bottom,
292 -- but we don't want the code generator to fall over here. If we
293 -- just emit an assignment here, the assignment will be
294 -- type-incorrect Cmm. Hence, we emit the usual enter/return code,
295 -- (and because bottom must be untagged, it will be entered and the
296 -- program will crash).
297 -- The Sequel is a type-correct assignment, albeit bogus.
298 -- The (dead) continuation loops; it would be better to invoke some kind
299 -- of panic function here.
300 --
301 -- However, we also want to allow an assignment to be generated
302 -- in the case when the types are compatible, because this allows
303 -- some slightly-dodgy but occasionally-useful casts to be used,
304 -- such as in RtClosureInspect where we cast an HValue to a MutVar#
305 -- so we can print out the contents of the MutVar#. If we generate
306 -- code that enters the HValue, then we'll get a runtime panic, because
307 -- the HValue really is a MutVar#. The types are compatible though,
308 -- so we can just generate an assignment.
309 cgCase (StgApp v []) bndr _ alt_type@(PrimAlt _) alts
310 | isUnLiftedType (idType v)
311 || reps_compatible
312 = -- assignment suffices for unlifted types
313 do { when (not reps_compatible) $
314 panic "cgCase: reps do not match, perhaps a dodgy unsafeCoerce?"
315 ; v_info <- getCgIdInfo v
316 ; emit (mkAssign (CmmLocal (idToReg (NonVoid bndr))) (idInfoToAmode v_info))
317 ; _ <- bindArgsToRegs [NonVoid bndr]
318 ; cgAlts NoGcInAlts (NonVoid bndr) alt_type alts }
319 where
320 reps_compatible = idCgRep v == idCgRep bndr
321
322 cgCase scrut@(StgApp v []) _ _ (PrimAlt _) _
323 = -- fail at run-time, not compile-time
324 do { mb_cc <- maybeSaveCostCentre True
325 ; withSequel (AssignTo [idToReg (NonVoid v)] False) (cgExpr scrut)
326 ; restoreCurrentCostCentre mb_cc
327 ; emit $ mkComment $ mkFastString "should be unreachable code"
328 ; emit $ withFreshLabel "l" (\l -> mkLabel l <*> mkBranch l)}
329
330 {-
331 case seq# a s of v
332 (# s', a' #) -> e
333
334 ==>
335
336 case a of v
337 (# s', a' #) -> e
338
339 (taking advantage of the fact that the return convention for (# State#, a #)
340 is the same as the return convention for just 'a')
341 -}
342 cgCase (StgOpApp (StgPrimOp SeqOp) [StgVarArg a, _] _) bndr srt alt_type alts
343 = -- handle seq#, same return convention as vanilla 'a'.
344 cgCase (StgApp a []) bndr srt alt_type alts
345
346 cgCase scrut bndr srt alt_type alts
347 = -- the general case
348 do { up_hp_usg <- getVirtHp -- Upstream heap usage
349 ; let ret_bndrs = chooseReturnBndrs bndr alt_type alts
350 alt_regs = map idToReg ret_bndrs
351 simple_scrut = isSimpleScrut scrut alt_type
352 gcInAlts | not simple_scrut = True
353 | isSingleton alts = False
354 | up_hp_usg > 0 = False
355 | otherwise = True
356 gc_plan = if gcInAlts then GcInAlts alt_regs srt else NoGcInAlts
357
358 ; mb_cc <- maybeSaveCostCentre simple_scrut
359 ; withSequel (AssignTo alt_regs gcInAlts) (cgExpr scrut)
360 ; restoreCurrentCostCentre mb_cc
361
362 -- JD: We need Note: [Better Alt Heap Checks]
363 ; _ <- bindArgsToRegs ret_bndrs
364 ; cgAlts gc_plan (NonVoid bndr) alt_type alts }
365
366 -----------------
367 maybeSaveCostCentre :: Bool -> FCode (Maybe LocalReg)
368 maybeSaveCostCentre simple_scrut
369 | simple_scrut = saveCurrentCostCentre
370 | otherwise = return Nothing
371
372
373 -----------------
374 isSimpleScrut :: StgExpr -> AltType -> Bool
375 -- Simple scrutinee, does not block or allocate; hence safe to amalgamate
376 -- heap usage from alternatives into the stuff before the case
377 -- NB: if you get this wrong, and claim that the expression doesn't allocate
378 -- when it does, you'll deeply mess up allocation
379 isSimpleScrut (StgOpApp op _ _) _ = isSimpleOp op
380 isSimpleScrut (StgLit _) _ = True -- case 1# of { 0# -> ..; ... }
381 isSimpleScrut (StgApp _ []) (PrimAlt _) = True -- case x# of { 0# -> ..; ... }
382 isSimpleScrut _ _ = False
383
384 isSimpleOp :: StgOp -> Bool
385 -- True iff the op cannot block or allocate
386 isSimpleOp (StgFCallOp (CCall (CCallSpec _ _ safe)) _) = not (playSafe safe)
387 isSimpleOp (StgPrimOp op) = not (primOpOutOfLine op)
388 isSimpleOp (StgPrimCallOp _) = False
389
390 -----------------
391 chooseReturnBndrs :: Id -> AltType -> [StgAlt] -> [NonVoid Id]
392 -- These are the binders of a case that are assigned
393 -- by the evaluation of the scrutinee
394 -- Only non-void ones come back
395 chooseReturnBndrs bndr (PrimAlt _) _alts
396 = nonVoidIds [bndr]
397
398 chooseReturnBndrs _bndr (UbxTupAlt _) [(_, ids, _, _)]
399 = nonVoidIds ids -- 'bndr' is not assigned!
400
401 chooseReturnBndrs bndr (AlgAlt _) _alts
402 = nonVoidIds [bndr] -- Only 'bndr' is assigned
403
404 chooseReturnBndrs bndr PolyAlt _alts
405 = nonVoidIds [bndr] -- Only 'bndr' is assigned
406
407 chooseReturnBndrs _ _ _ = panic "chooseReturnBndrs"
408 -- UbxTupALt has only one alternative
409
410 -------------------------------------
411 cgAlts :: GcPlan -> NonVoid Id -> AltType -> [StgAlt] -> FCode ()
412 -- At this point the result of the case are in the binders
413 cgAlts gc_plan _bndr PolyAlt [(_, _, _, rhs)]
414 = maybeAltHeapCheck gc_plan (cgExpr rhs)
415
416 cgAlts gc_plan _bndr (UbxTupAlt _) [(_, _, _, rhs)]
417 = maybeAltHeapCheck gc_plan (cgExpr rhs)
418 -- Here bndrs are *already* in scope, so don't rebind them
419
420 cgAlts gc_plan bndr (PrimAlt _) alts
421 = do { tagged_cmms <- cgAltRhss gc_plan bndr alts
422
423 ; let bndr_reg = CmmLocal (idToReg bndr)
424 (DEFAULT,deflt) = head tagged_cmms
425 -- PrimAlts always have a DEFAULT case
426 -- and it always comes first
427
428 tagged_cmms' = [(lit,code)
429 | (LitAlt lit, code) <- tagged_cmms]
430 ; emit (mkCmmLitSwitch (CmmReg bndr_reg) tagged_cmms' deflt) }
431
432 cgAlts gc_plan bndr (AlgAlt tycon) alts
433 = do { tagged_cmms <- cgAltRhss gc_plan bndr alts
434
435 ; let fam_sz = tyConFamilySize tycon
436 bndr_reg = CmmLocal (idToReg bndr)
437 mb_deflt = case tagged_cmms of
438 ((DEFAULT,rhs) : _) -> Just rhs
439 _other -> Nothing
440 -- DEFAULT is always first, if present
441
442 branches = [ (dataConTagZ con, cmm)
443 | (DataAlt con, cmm) <- tagged_cmms ]
444
445 -- Is the constructor tag in the node reg?
446 ; if isSmallFamily fam_sz
447 then let -- Yes, bndr_reg has constr. tag in ls bits
448 tag_expr = cmmConstrTag1 (CmmReg bndr_reg)
449 branches' = [(tag+1,branch) | (tag,branch) <- branches]
450 in
451 emitSwitch tag_expr branches' mb_deflt 1 fam_sz
452
453 else -- No, get tag from info table
454 let -- Note that ptr _always_ has tag 1
455 -- when the family size is big enough
456 untagged_ptr = cmmRegOffB bndr_reg (-1)
457 tag_expr = getConstrTag (untagged_ptr)
458 in
459 emitSwitch tag_expr branches mb_deflt 0 (fam_sz - 1) }
460
461 cgAlts _ _ _ _ = panic "cgAlts"
462 -- UbxTupAlt and PolyAlt have only one alternative
463
464 -------------------
465 cgAltRhss :: GcPlan -> NonVoid Id -> [StgAlt] -> FCode [(AltCon, CmmAGraph)]
466 cgAltRhss gc_plan bndr alts
467 = forkAlts (map cg_alt alts)
468 where
469 base_reg = idToReg bndr
470 cg_alt :: StgAlt -> FCode (AltCon, CmmAGraph)
471 cg_alt (con, bndrs, _uses, rhs)
472 = getCodeR $
473 maybeAltHeapCheck gc_plan $
474 do { _ <- bindConArgs con base_reg bndrs
475 ; cgExpr rhs
476 ; return con }
477
478 maybeAltHeapCheck :: GcPlan -> FCode a -> FCode a
479 maybeAltHeapCheck NoGcInAlts code = code
480 maybeAltHeapCheck (GcInAlts regs _) code = altHeapCheck regs code
481
482 -----------------------------------------------------------------------------
483 -- Tail calls
484 -----------------------------------------------------------------------------
485
486 cgConApp :: DataCon -> [StgArg] -> FCode ()
487 cgConApp con stg_args
488 | isUnboxedTupleCon con -- Unboxed tuple: assign and return
489 = do { arg_exprs <- getNonVoidArgAmodes stg_args
490 ; tickyUnboxedTupleReturn (length arg_exprs)
491 ; emitReturn arg_exprs }
492
493 | otherwise -- Boxed constructors; allocate and return
494 = ASSERT( stg_args `lengthIs` dataConRepArity con )
495 do { (idinfo, init) <- buildDynCon (dataConWorkId con) currentCCS con stg_args
496 -- The first "con" says that the name bound to this closure is
497 -- is "con", which is a bit of a fudge, but it only affects profiling
498
499 ; emit init
500 ; emitReturn [idInfoToAmode idinfo] }
501
502
503 cgIdApp :: Id -> [StgArg] -> FCode ()
504 cgIdApp fun_id [] | isVoidId fun_id = emitReturn []
505 cgIdApp fun_id args
506 = do { fun_info <- getCgIdInfo fun_id
507 ; case maybeLetNoEscape fun_info of
508 Just (blk_id, lne_regs) -> cgLneJump blk_id lne_regs args
509 Nothing -> cgTailCall fun_id fun_info args }
510
511 cgLneJump :: BlockId -> [LocalReg] -> [StgArg] -> FCode ()
512 cgLneJump blk_id lne_regs args -- Join point; discard sequel
513 = do { cmm_args <- getNonVoidArgAmodes args
514 ; emit (mkMultiAssign lne_regs cmm_args
515 <*> mkBranch blk_id) }
516
517 cgTailCall :: Id -> CgIdInfo -> [StgArg] -> FCode ()
518 cgTailCall fun_id fun_info args = do
519 dflags <- getDynFlags
520 case (getCallMethod dflags fun_name (idCafInfo fun_id) lf_info (length args)) of
521
522 -- A value in WHNF, so we can just return it.
523 ReturnIt -> emitReturn [fun] -- ToDo: does ReturnIt guarantee tagged?
524
525 EnterIt -> ASSERT( null args ) -- Discarding arguments
526 do { let fun' = CmmLoad fun (cmmExprType fun)
527 ; [ret,call] <- forkAlts [
528 getCode $ emitReturn [fun], -- Is tagged; no need to untag
529 getCode $ do -- emit (mkAssign nodeReg fun)
530 emitCall (NativeNodeCall, NativeReturn)
531 (entryCode fun') [fun]] -- Not tagged
532 ; emit (mkCmmIfThenElse (cmmIsTagged fun) ret call) }
533
534 SlowCall -> do -- A slow function call via the RTS apply routines
535 { tickySlowCall lf_info args
536 ; emit $ mkComment $ mkFastString "slowCall"
537 ; slowCall fun args }
538
539 -- A direct function call (possibly with some left-over arguments)
540 DirectEntry lbl arity -> do
541 { tickyDirectCall arity args
542 ; if node_points then
543 do emit $ mkComment $ mkFastString "directEntry"
544 emit (mkAssign nodeReg fun)
545 directCall lbl arity args
546 else do emit $ mkComment $ mkFastString "directEntry else"
547 directCall lbl arity args }
548
549 JumpToIt {} -> panic "cgTailCall" -- ???
550
551 where
552 fun_name = idName fun_id
553 fun = idInfoToAmode fun_info
554 lf_info = cgIdInfoLF fun_info
555 node_points = nodeMustPointToIt lf_info
556
557
558 {- Note [case on Bool]
559 ~~~~~~~~~~~~~~~~~~~
560 A case on a Boolean value does two things:
561 1. It looks up the Boolean in a closure table and assigns the
562 result to the binder.
563 2. It branches to the True or False case through analysis
564 of the closure assigned to the binder.
565 But the indirection through the closure table is unnecessary
566 if the assignment to the binder will be dead code (use isDeadBndr).
567
568 The following example illustrates how badly the code turns out:
569 STG:
570 case <=## [ww_s7Hx y_s7HD] of wild2_sbH8 {
571 GHC.Types.False -> <true code> // sbH8 dead
572 GHC.Types.True -> <false code> // sbH8 dead
573 };
574 Cmm:
575 _s7HD::F64 = F64[_sbH7::I64 + 7]; // MidAssign
576 _ccsW::I64 = %MO_F_Le_W64(_s7Hx::F64, _s7HD::F64); // MidAssign
577 // emitReturn // MidComment
578 _sbH8::I64 = I64[ghczmprim_GHCziBool_Bool_closure_tbl + (_ccsW::I64 << 3)]; // MidAssign
579 _ccsX::I64 = _sbH8::I64 & 7; // MidAssign
580 if (_ccsX::I64 >= 2) goto ccsH; else goto ccsI; // LastCondBranch
581
582 The assignments to _sbH8 and _ccsX are completely unnecessary.
583 Instead, we should branch based on the value of _ccsW.
584 -}
585
586 {- Note [Better Alt Heap Checks]
587 If two function calls can share a return point, then they will also
588 get the same info table. Therefore, it's worth our effort to make
589 those opportunities appear as frequently as possible.
590
591 Here are a few examples of how it should work:
592
593 STG:
594 case f x of
595 True -> <True code -- including allocation>
596 False -> <False code>
597 Cmm:
598 r = call f(x) returns to L;
599 L:
600 if r & 7 >= 2 goto L1 else goto L2;
601 L1:
602 if Hp > HpLim then
603 r = gc(r);
604 goto L;
605 <True code -- including allocation>
606 L2:
607 <False code>
608 Note that the code following both the call to f(x) and the code to gc(r)
609 should be the same, which will allow the common blockifier to discover
610 that they are the same. Therefore, both function calls will return to the same
611 block, and they will use the same info table.
612
613 Here's an example of the Cmm code we want from a primOp.
614 The primOp doesn't produce an info table for us to reuse, but that's okay:
615 we should still generate the same code:
616 STG:
617 case f x of
618 0 -> <0-case code -- including allocation>
619 _ -> <default-case code>
620 Cmm:
621 r = a +# b;
622 L:
623 if r == 0 then goto L1 else goto L2;
624 L1:
625 if Hp > HpLim then
626 r = gc(r);
627 goto L;
628 <0-case code -- including allocation>
629 L2:
630 <default-case code>
631 -}
632