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