2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 % $Id: CgCase.lhs,v 1.59 2002/09/04 10:00:45 simonmar Exp $
6 %********************************************************
8 \section[CgCase]{Converting @StgCase@ expressions}
10 %********************************************************
13 module CgCase ( cgCase, saveVolatileVarsAndRegs, restoreCurrentCostCentre
16 #include "HsVersions.h"
18 import {-# SOURCE #-} CgExpr ( cgExpr )
24 import AbsCUtils ( mkAbstractCs, mkAbsCStmts, mkAlgAltsCSwitch,
25 getAmodeRep, nonemptyAbsC
27 import CgUpdate ( reserveSeqFrame )
28 import CgBindery ( getVolatileRegs, getArgAmodes,
29 bindNewToReg, bindNewToTemp,
30 bindNewPrimToAmode, getCAddrModeAndInfo,
31 rebindToStack, getCAddrMode, getCAddrModeIfVolatile,
32 buildContLivenessMask, nukeDeadBindings,
34 import CgCon ( bindConArgs, bindUnboxedTupleComponents )
35 import CgHeapery ( altHeapCheck )
36 import CgRetConv ( dataReturnConvPrim, ctrlReturnConvAlg,
37 CtrlReturnConvention(..)
39 import CgStackery ( allocPrimStack, allocStackTop,
40 deAllocStackTop, freeStackSlots, dataStackSlots
42 import CgTailCall ( tailCallFun )
43 import CgUsages ( getSpRelOffset )
44 import CLabel ( mkVecTblLabel, mkClosureTblLabel,
45 mkDefaultLabel, mkAltLabel, mkReturnInfoLabel
47 import ClosureInfo ( mkLFArgument )
48 import CmdLineOpts ( opt_SccProfilingOn )
49 import Id ( Id, idPrimRep, isDeadBinder )
50 import DataCon ( DataCon, dataConTag, fIRST_TAG, ConTag )
51 import VarSet ( varSetElems )
52 import Literal ( Literal )
53 import PrimOp ( primOpOutOfLine, PrimOp(..) )
54 import PrimRep ( getPrimRepSize, retPrimRepSize, PrimRep(..)
56 import TyCon ( isEnumerationTyCon, isUnboxedTupleTyCon, tyConPrimRep )
57 import Unique ( Unique, Uniquable(..), newTagUnique )
58 import Maybes ( maybeToBool )
65 = GCMayHappen -- The scrutinee may involve GC, so everything must be
66 -- tidy before the code for the scrutinee.
68 | NoGC -- The scrutinee is a primitive value, or a call to a
69 -- primitive op which does no GC. Hence the case can
70 -- be done inline, without tidying up first.
73 It is quite interesting to decide whether to put a heap-check
74 at the start of each alternative. Of course we certainly have
75 to do so if the case forces an evaluation, or if there is a primitive
76 op which can trigger GC.
78 A more interesting situation is this:
85 default -> !C!; ...C...
88 where \tr{!x!} indicates a possible heap-check point. The heap checks
89 in the alternatives {\em can} be omitted, in which case the topmost
90 heapcheck will take their worst case into account.
92 In favour of omitting \tr{!B!}, \tr{!C!}:
94 - {\em May} save a heap overflow test,
95 if ...A... allocates anything. The other advantage
96 of this is that we can use relative addressing
97 from a single Hp to get at all the closures so allocated.
99 - No need to save volatile vars etc across the case
103 - May do more allocation than reqd. This sometimes bites us
104 badly. For example, nfib (ha!) allocates about 30\% more space if the
105 worst-casing is done, because many many calls to nfib are leaf calls
106 which don't need to allocate anything.
108 This never hurts us if there is only one alternative.
120 Special case #1: PrimOps returning enumeration types.
122 For enumeration types, we invent a temporary (builtin-unique 1) to
123 hold the tag, and cross our fingers that this doesn't clash with
124 anything else. Builtin-unique 0 is used for a similar reason when
125 compiling enumerated-type primops in CgExpr.lhs. We can't use the
126 unique from the case binder, because this is used to hold the actual
127 closure (when the case binder is live, that is).
129 There is an extra special case for
134 which generates no code for the primop, unless x is used in the
135 alternatives (in which case we lookup the tag in the relevant closure
136 table to get the closure).
138 Being a bit short of uniques for temporary variables here, we use
139 newTagUnique to generate a new unique from the case binder. The case
140 binder's unique will presumably have the 'c' tag (generated by
141 CoreToStg), so we just change its tag to 'C' (for 'case') to ensure it
142 doesn't clash with anything else.
145 cgCase (StgOpApp op args _)
146 live_in_whole_case live_in_alts bndr srt (StgAlgAlts (Just tycon) alts deflt)
147 | isEnumerationTyCon tycon
148 = getArgAmodes args `thenFC` \ arg_amodes ->
151 StgPrimOp TagToEnumOp -- No code!
152 -> returnFC (only arg_amodes) ;
154 _ -> -- Perform the operation
156 tag_amode = CTemp (newTagUnique (getUnique bndr) 'C') IntRep
158 getVolatileRegs live_in_alts `thenFC` \ vol_regs ->
159 absC (COpStmt [tag_amode] op arg_amodes vol_regs)
161 -- NB: no liveness arg
163 } `thenFC` \ tag_amode ->
166 closure = CVal (CIndex (CLbl (mkClosureTblLabel tycon) PtrRep)
171 -- Bind the default binder if necessary
172 -- The deadness info is set by StgVarInfo
173 (if (isDeadBinder bndr)
175 else bindNewToTemp bndr `thenFC` \ bndr_amode ->
176 absC (CAssign bndr_amode closure))
180 cgAlgAlts NoGC (getUnique bndr) Nothing{-cc_slot-} False{-no semi-tagging-}
181 False{-not poly case-} alts deflt
182 False{-don't emit yield-} `thenFC` \ (tagged_alts, deflt_c) ->
185 absC (mkAlgAltsCSwitch tag_amode tagged_alts deflt_c)
188 Special case #2: case of literal.
191 cgCase (StgLit lit) live_in_whole_case live_in_alts bndr srt alts =
192 absC (CAssign (CTemp (getUnique bndr) (idPrimRep bndr)) (CLit lit)) `thenC`
194 StgPrimAlts tycon alts deflt -> cgPrimInlineAlts bndr tycon alts deflt
195 other -> pprPanic "cgCase: case of literal has strange alts" (pprStgAlts alts)
198 Special case #3: inline PrimOps.
201 cgCase (StgOpApp op@(StgPrimOp primop) args _)
202 live_in_whole_case live_in_alts bndr srt alts
203 | not (primOpOutOfLine primop)
205 -- Get amodes for the arguments and results
206 getArgAmodes args `thenFC` \ arg_amodes ->
207 getVolatileRegs live_in_alts `thenFC` \ vol_regs ->
210 StgPrimAlts tycon alts deflt -- PRIMITIVE ALTS
211 -> absC (COpStmt [CTemp (getUnique bndr) (tyConPrimRep tycon)]
213 arg_amodes -- note: no liveness arg
215 cgPrimInlineAlts bndr tycon alts deflt
217 StgAlgAlts (Just tycon) [(_, args, _, rhs)] StgNoDefault
218 | isUnboxedTupleTyCon tycon -- UNBOXED TUPLE ALTS
219 -> -- no heap check, no yield, just get in there and do it.
220 absC (COpStmt [ CTemp (getUnique arg) (idPrimRep arg) | arg <- args ]
222 arg_amodes -- note: no liveness arg
224 mapFCs bindNewToTemp args `thenFC` \ _ ->
227 other -> pprPanic "cgCase: case of primop has strange alts" (pprStgAlts alts)
230 TODO: Case-of-case of primop can probably be done inline too (but
231 maybe better to translate it out beforehand). See
232 ghc/lib/misc/PackedString.lhs for examples where this crops up (with
235 Another special case: scrutinising a primitive-typed variable. No
236 evaluation required. We don't save volatile variables, nor do we do a
237 heap-check in the alternatives. Instead, the heap usage of the
238 alternatives is worst-cased and passed upstream. This can result in
239 allocating more heap than strictly necessary, but it will sometimes
240 eliminate a heap check altogether.
243 cgCase (StgApp v []) live_in_whole_case live_in_alts bndr srt
244 (StgPrimAlts tycon alts deflt)
247 getCAddrMode v `thenFC` \amode ->
250 Careful! we can't just bind the default binder to the same thing
251 as the scrutinee, since it might be a stack location, and having
252 two bindings pointing at the same stack locn doesn't work (it
253 confuses nukeDeadBindings). Hence, use a new temp.
255 bindNewToTemp bndr `thenFC` \deflt_amode ->
256 absC (CAssign deflt_amode amode) `thenC`
258 cgPrimAlts NoGC amode alts deflt []
261 Special case: scrutinising a non-primitive variable.
262 This can be done a little better than the general case, because
263 we can reuse/trim the stack slot holding the variable (if it is in one).
266 cgCase (StgApp fun args)
267 live_in_whole_case live_in_alts bndr srt alts
268 = getCAddrModeAndInfo fun `thenFC` \ (fun', fun_amode, lf_info) ->
269 getArgAmodes args `thenFC` \ arg_amodes ->
271 -- Squish the environment
272 nukeDeadBindings live_in_alts `thenC`
273 saveVolatileVarsAndRegs live_in_alts
274 `thenFC` \ (save_assts, alts_eob_info, maybe_cc_slot) ->
276 allocStackTop retPrimRepSize `thenFC` \_ ->
278 forkEval alts_eob_info nopC (
279 deAllocStackTop retPrimRepSize `thenFC` \_ ->
280 cgEvalAlts maybe_cc_slot bndr srt alts)
281 `thenFC` \ scrut_eob_info ->
283 setEndOfBlockInfo (maybeReserveSeqFrame alts scrut_eob_info) $
284 tailCallFun fun' fun_amode lf_info arg_amodes save_assts
287 Note about return addresses: we *always* push a return address, even
288 if because of an optimisation we end up jumping direct to the return
289 code (not through the address itself). The alternatives always assume
290 that the return address is on the stack. The return address is
291 required in case the alternative performs a heap check, since it
292 encodes the liveness of the slots in the activation record.
294 On entry to the case alternative, we can re-use the slot containing
295 the return address immediately after the heap check. That's what the
296 deAllocStackTop call is doing above.
298 Finally, here is the general case.
301 cgCase expr live_in_whole_case live_in_alts bndr srt alts
302 = -- Figure out what volatile variables to save
303 nukeDeadBindings live_in_whole_case `thenC`
305 saveVolatileVarsAndRegs live_in_alts
306 `thenFC` \ (save_assts, alts_eob_info, maybe_cc_slot) ->
308 -- Save those variables right now!
309 absC save_assts `thenC`
311 -- generate code for the alts
312 forkEval alts_eob_info
313 (nukeDeadBindings live_in_alts `thenC`
314 allocStackTop retPrimRepSize -- space for retn address
317 (deAllocStackTop retPrimRepSize `thenFC` \_ ->
318 cgEvalAlts maybe_cc_slot bndr srt alts) `thenFC` \ scrut_eob_info ->
320 setEndOfBlockInfo (maybeReserveSeqFrame alts scrut_eob_info) $
324 There's a lot of machinery going on behind the scenes to manage the
325 stack pointer here. forkEval takes the virtual Sp and free list from
326 the first argument, and turns that into the *real* Sp for the second
327 argument. It also uses this virtual Sp as the args-Sp in the EOB info
328 returned, so that the scrutinee will trim the real Sp back to the
329 right place before doing whatever it does.
330 --SDM (who just spent an hour figuring this out, and didn't want to
333 Why don't we push the return address just before evaluating the
334 scrutinee? Because the slot reserved for the return address might
335 contain something useful, so we wait until performing a tail call or
336 return before pushing the return address (see
337 CgTailCall.pushReturnAddress).
339 This also means that the environment doesn't need to know about the
340 free stack slot for the return address (for generating bitmaps),
341 because we don't reserve it until just before the eval.
343 TODO!! Problem: however, we have to save the current cost centre
344 stack somewhere, because at the eval point the current CCS might be
345 different. So we pick a free stack slot and save CCCS in it. The
346 problem with this is that this slot isn't recorded as free/unboxed in
347 the environment, so a case expression in the scrutinee will have the
348 wrong bitmap attached. Fortunately we don't ever seem to see
349 case-of-case at the back end. One solution might be to shift the
350 saved CCS to the correct place in the activation record just before
354 (one consequence of the above is that activation records on the stack
355 don't follow the layout of closures when we're profiling. The CCS
356 could be anywhere within the record).
359 -- We need to reserve a seq frame for a polymorphic case
360 maybeReserveSeqFrame (StgAlgAlts Nothing _ _) scrut_eob_info = reserveSeqFrame scrut_eob_info
361 maybeReserveSeqFrame other scrut_eob_info = scrut_eob_info
364 %************************************************************************
366 \subsection[CgCase-alts]{Alternatives}
368 %************************************************************************
370 @cgEvalAlts@ returns an addressing mode for a continuation for the
371 alternatives of a @case@, used in a context when there
372 is some evaluation to be done.
375 cgEvalAlts :: Maybe VirtualSpOffset -- Offset of cost-centre to be restored, if any
377 -> SRT -- SRT for the continuation
379 -> FCode Sequel -- Any addr modes inside are guaranteed
380 -- to be a label so that we can duplicate it
381 -- without risk of duplicating code
383 cgEvalAlts cc_slot bndr srt alts
385 let uniq = getUnique bndr in
387 buildContLivenessMask uniq `thenFC` \ liveness_mask ->
391 -- algebraic alts ...
392 StgAlgAlts maybe_tycon alts deflt ->
394 -- bind the default binder (it covers all the alternatives)
395 bindNewToReg bndr node mkLFArgument `thenC`
397 -- Generate sequel info for use downstream
398 -- At the moment, we only do it if the type is vector-returnable.
399 -- Reason: if not, then it costs extra to label the
400 -- alternatives, because we'd get return code like:
402 -- switch TagReg { 0 : JMP(alt_1); 1 : JMP(alt_2) ..etc }
404 -- which is worse than having the alt code in the switch statement
406 let is_alg = maybeToBool maybe_tycon
407 Just spec_tycon = maybe_tycon
410 -- Deal with the unboxed tuple case
411 if is_alg && isUnboxedTupleTyCon spec_tycon then
412 -- By now, the simplifier should have have turned it
413 -- into case e of (# a,b #) -> e
414 -- There shouldn't be a
415 -- case e of DEFAULT -> e
416 ASSERT2( case (alts, deflt) of { ([_],StgNoDefault) -> True; other -> False },
417 text "cgEvalAlts: dodgy case of unboxed tuple type" )
420 lbl = mkReturnInfoLabel uniq
422 cgUnboxedTupleAlt uniq cc_slot True alt `thenFC` \ abs_c ->
423 getSRTInfo srt `thenFC` \ srt_info ->
424 absC (CRetDirect uniq abs_c srt_info liveness_mask) `thenC`
425 returnFC (CaseAlts (CLbl lbl RetRep) Nothing)
427 -- normal algebraic (or polymorphic) case alternatives
429 ret_conv | is_alg = ctrlReturnConvAlg spec_tycon
430 | otherwise = UnvectoredReturn 0
432 use_labelled_alts = case ret_conv of
433 VectoredReturn _ -> True
437 = if use_labelled_alts then
438 cgSemiTaggedAlts bndr alts deflt -- Just <something>
440 Nothing -- no semi-tagging info
443 cgAlgAlts GCMayHappen uniq cc_slot use_labelled_alts (not is_alg)
444 alts deflt True `thenFC` \ (tagged_alt_absCs, deflt_absC) ->
446 mkReturnVector uniq tagged_alt_absCs deflt_absC srt liveness_mask
447 ret_conv `thenFC` \ return_vec ->
449 returnFC (CaseAlts return_vec semi_tagged_stuff)
452 StgPrimAlts tycon alts deflt ->
454 -- Restore the cost centre
455 restoreCurrentCostCentre cc_slot `thenFC` \ cc_restore ->
457 -- Generate the switch
458 getAbsC (cgPrimEvalAlts bndr tycon alts deflt) `thenFC` \ abs_c ->
460 -- Generate the labelled block, starting with restore-cost-centre
461 getSRTInfo srt `thenFC` \srt_info ->
462 absC (CRetDirect uniq (cc_restore `mkAbsCStmts` abs_c)
463 srt_info liveness_mask) `thenC`
465 -- Return an amode for the block
466 returnFC (CaseAlts (CLbl (mkReturnInfoLabel uniq) RetRep) Nothing)
470 HWL comment on {\em GrAnSim\/} (adding GRAN_YIELDs for context switch): If
471 we do an inlining of the case no separate functions for returning are
472 created, so we don't have to generate a GRAN_YIELD in that case. This info
473 must be propagated to cgAlgAltRhs (where the GRAN_YIELD macro might be
474 emitted). Hence, the new Bool arg to cgAlgAltRhs.
476 %************************************************************************
478 \subsection[CgCase-alg-alts]{Algebraic alternatives}
480 %************************************************************************
482 In @cgAlgAlts@, none of the binders in the alternatives are
483 assumed to be yet bound.
485 HWL comment on {\em GrAnSim\/} (adding GRAN_YIELDs for context switch): The
486 last arg of cgAlgAlts indicates if we want a context switch at the
487 beginning of each alternative. Normally we want that. The only exception
488 are inlined alternatives.
493 -> Maybe VirtualSpOffset
494 -> Bool -- True <=> branches must be labelled
495 -> Bool -- True <=> polymorphic case
496 -> [(DataCon, [Id], [Bool], StgExpr)] -- The alternatives
497 -> StgCaseDefault -- The default
498 -> Bool -- Context switch at alts?
499 -> FCode ([(ConTag, AbstractC)], -- The branches
500 AbstractC -- The default case
503 cgAlgAlts gc_flag uniq restore_cc must_label_branches is_poly alts deflt
504 emit_yield{-should a yield macro be emitted?-}
506 = forkAlts (map (cgAlgAlt gc_flag uniq restore_cc must_label_branches emit_yield) alts)
507 (cgAlgDefault gc_flag is_poly uniq restore_cc must_label_branches deflt emit_yield)
511 cgAlgDefault :: GCFlag
512 -> Bool -- could be a function-typed result?
513 -> Unique -> Maybe VirtualSpOffset -> Bool -- turgid state...
514 -> StgCaseDefault -- input
516 -> FCode AbstractC -- output
518 cgAlgDefault gc_flag is_poly uniq cc_slot must_label_branch StgNoDefault _
521 cgAlgDefault gc_flag is_poly uniq cc_slot must_label_branch
523 emit_yield{-should a yield macro be emitted?-}
525 = -- We have arranged that Node points to the thing
526 restoreCurrentCostCentre cc_slot `thenFC` \restore_cc ->
527 getAbsC (absC restore_cc `thenC`
528 -- HWL: maybe need yield here
530 -- then yield [node] True
531 -- else absC AbsCNop) `thenC`
532 algAltHeapCheck gc_flag is_poly [node] [] Nothing (cgExpr rhs)
533 -- Node is live, but doesn't need to point at the thing itself;
534 -- it's ok for Node to point to an indirection or FETCH_ME
535 -- Hence no need to re-enter Node.
536 ) `thenFC` \ abs_c ->
539 final_abs_c | must_label_branch = CCodeBlock lbl abs_c
544 lbl = mkDefaultLabel uniq
546 -- HWL comment on GrAnSim: GRAN_YIELDs needed; emitted in cgAlgAltRhs
549 -> Unique -> Maybe VirtualSpOffset -> Bool -- turgid state
550 -> Bool -- Context switch at alts?
551 -> (DataCon, [Id], [Bool], StgExpr)
552 -> FCode (ConTag, AbstractC)
554 cgAlgAlt gc_flag uniq cc_slot must_label_branch
555 emit_yield{-should a yield macro be emitted?-}
556 (con, args, use_mask, rhs)
558 restoreCurrentCostCentre cc_slot `thenFC` \restore_cc ->
559 getAbsC (absC restore_cc `thenC`
560 -- HWL: maybe need yield here
562 -- then yield [node] True -- XXX live regs wrong
563 -- else absC AbsCNop) `thenC`
565 NoGC -> mapFCs bindNewToTemp args `thenFC` \_ -> nopC
566 GCMayHappen -> bindConArgs con args
568 algAltHeapCheck gc_flag False [node] [] Nothing (
570 ) `thenFC` \ abs_c ->
572 final_abs_c | must_label_branch = CCodeBlock lbl abs_c
575 returnFC (tag, final_abs_c)
578 lbl = mkAltLabel uniq tag
581 :: Unique -- unique for label of the alternative
582 -> Maybe VirtualSpOffset -- Restore cost centre
583 -> Bool -- ctxt switch
584 -> (DataCon, [Id], [Bool], StgExpr) -- alternative
587 cgUnboxedTupleAlt lbl cc_slot emit_yield (con,args,use_mask,rhs)
589 bindUnboxedTupleComponents args
590 `thenFC` \ (live_regs,tags,stack_res) ->
592 restoreCurrentCostCentre cc_slot `thenFC` \restore_cc ->
593 absC restore_cc `thenC`
595 -- HWL: maybe need yield here
597 -- then yield live_regs True -- XXX live regs wrong?
598 -- else absC AbsCNop) `thenC`
600 -- ToDo: could maybe use Nothing here if stack_res is False
601 -- since the heap-check can just return to the top of the
606 -- free up stack slots containing tags,
607 freeStackSlots (map fst tags) `thenC`
609 -- generate a heap check if necessary
610 primAltHeapCheck GCMayHappen live_regs tags ret_addr (
612 -- and finally the code for the alternative
617 %************************************************************************
619 \subsection[CgCase-semi-tagged-alts]{The code to deal with sem-tagging}
621 %************************************************************************
623 Turgid-but-non-monadic code to conjure up the required info from
624 algebraic case alternatives for semi-tagging.
627 cgSemiTaggedAlts :: Id
628 -> [(DataCon, [Id], [Bool], StgExpr)]
629 -> GenStgCaseDefault Id Id
632 cgSemiTaggedAlts binder alts deflt
633 = Just (map st_alt alts, st_deflt deflt)
635 uniq = getUnique binder
637 st_deflt StgNoDefault = Nothing
639 st_deflt (StgBindDefault _)
641 (CCallProfCtrMacro FSLIT("RET_SEMI_BY_DEFAULT") [], -- ToDo: monadise?
645 st_alt (con, args, use_mask, _)
646 = -- Ha! Nothing to do; Node already points to the thing
648 (CCallProfCtrMacro FSLIT("RET_SEMI_IN_HEAP") -- ToDo: monadise?
649 [mkIntCLit (length args)], -- how big the thing in the heap is
653 con_tag = dataConTag con
654 join_label = mkAltLabel uniq con_tag
657 %************************************************************************
659 \subsection[CgCase-prim-alts]{Primitive alternatives}
661 %************************************************************************
663 @cgPrimEvalAlts@ and @cgPrimInlineAlts@ generate suitable @CSwitch@es
664 for dealing with the alternatives of a primitive @case@, given an
665 addressing mode for the thing to scrutinise. It also keeps track of
666 the maximum stack depth encountered down any branch.
668 As usual, no binders in the alternatives are yet bound.
671 cgPrimInlineAlts bndr tycon alts deflt
672 = cgPrimAltsWithDefault bndr NoGC (CTemp uniq kind) alts deflt []
674 uniq = getUnique bndr
675 kind = tyConPrimRep tycon
677 cgPrimEvalAlts bndr tycon alts deflt
678 = cgPrimAltsWithDefault bndr GCMayHappen (CReg reg) alts deflt [reg]
680 reg = dataReturnConvPrim kind
681 kind = tyConPrimRep tycon
683 cgPrimAltsWithDefault bndr gc_flag scrutinee alts deflt regs
684 = -- first bind the default if necessary
685 bindNewPrimToAmode bndr scrutinee `thenC`
686 cgPrimAlts gc_flag scrutinee alts deflt regs
688 cgPrimAlts gc_flag scrutinee alts deflt regs
689 = forkAlts (map (cgPrimAlt gc_flag regs) alts)
690 (cgPrimDefault gc_flag regs deflt)
691 `thenFC` \ (alt_absCs, deflt_absC) ->
693 absC (CSwitch scrutinee alt_absCs deflt_absC)
694 -- CSwitch does sensible things with one or zero alternatives
698 -> [MagicId] -- live registers
699 -> (Literal, StgExpr) -- The alternative
700 -> FCode (Literal, AbstractC) -- Its compiled form
702 cgPrimAlt gc_flag regs (lit, rhs)
703 = getAbsC rhs_code `thenFC` \ absC ->
706 rhs_code = primAltHeapCheck gc_flag regs [] Nothing (cgExpr rhs)
708 cgPrimDefault :: GCFlag
709 -> [MagicId] -- live registers
713 cgPrimDefault gc_flag regs StgNoDefault
714 = panic "cgPrimDefault: No default in prim case"
716 cgPrimDefault gc_flag regs (StgBindDefault rhs)
717 = getAbsC (primAltHeapCheck gc_flag regs [] Nothing (cgExpr rhs))
721 %************************************************************************
723 \subsection[CgCase-tidy]{Code for tidying up prior to an eval}
725 %************************************************************************
728 saveVolatileVarsAndRegs
729 :: StgLiveVars -- Vars which should be made safe
730 -> FCode (AbstractC, -- Assignments to do the saves
731 EndOfBlockInfo, -- sequel for the alts
732 Maybe VirtualSpOffset) -- Slot for current cost centre
735 saveVolatileVarsAndRegs vars
736 = saveVolatileVars vars `thenFC` \ var_saves ->
737 saveCurrentCostCentre `thenFC` \ (maybe_cc_slot, cc_save) ->
738 getEndOfBlockInfo `thenFC` \ eob_info ->
739 returnFC (mkAbstractCs [var_saves, cc_save],
744 saveVolatileVars :: StgLiveVars -- Vars which should be made safe
745 -> FCode AbstractC -- Assignments to to the saves
747 saveVolatileVars vars
748 = save_em (varSetElems vars)
750 save_em [] = returnFC AbsCNop
753 = getCAddrModeIfVolatile var `thenFC` \ v ->
755 Nothing -> save_em vars -- Non-volatile, so carry on
758 Just vol_amode -> -- Aha! It's volatile
759 save_var var vol_amode `thenFC` \ abs_c ->
760 save_em vars `thenFC` \ abs_cs ->
761 returnFC (abs_c `mkAbsCStmts` abs_cs)
763 save_var var vol_amode
764 = allocPrimStack (getPrimRepSize kind) `thenFC` \ slot ->
765 rebindToStack var slot `thenC`
766 getSpRelOffset slot `thenFC` \ sp_rel ->
767 returnFC (CAssign (CVal sp_rel kind) vol_amode)
769 kind = getAmodeRep vol_amode
772 ---------------------------------------------------------------------------
774 When we save the current cost centre (which is done for lexical
775 scoping), we allocate a free stack location, and return (a)~the
776 virtual offset of the location, to pass on to the alternatives, and
777 (b)~the assignment to do the save (just as for @saveVolatileVars@).
780 saveCurrentCostCentre ::
781 FCode (Maybe VirtualSpOffset, -- Where we decide to store it
782 AbstractC) -- Assignment to save it
784 saveCurrentCostCentre
785 = if not opt_SccProfilingOn then
786 returnFC (Nothing, AbsCNop)
788 allocPrimStack (getPrimRepSize CostCentreRep) `thenFC` \ slot ->
789 dataStackSlots [slot] `thenC`
790 getSpRelOffset slot `thenFC` \ sp_rel ->
792 CAssign (CVal sp_rel CostCentreRep) (CReg CurCostCentre))
794 restoreCurrentCostCentre :: Maybe VirtualSpOffset -> FCode AbstractC
795 restoreCurrentCostCentre Nothing = returnFC AbsCNop
796 restoreCurrentCostCentre (Just slot)
797 = getSpRelOffset slot `thenFC` \ sp_rel ->
798 freeStackSlots [slot] `thenC`
799 returnFC (CCallProfCCMacro FSLIT("RESTORE_CCCS") [CVal sp_rel CostCentreRep])
800 -- we use the RESTORE_CCCS macro, rather than just
801 -- assigning into CurCostCentre, in case RESTORE_CCCS
802 -- has some sanity-checking in it.
805 %************************************************************************
807 \subsection[CgCase-return-vec]{Building a return vector}
809 %************************************************************************
811 Build a return vector, and return a suitable label addressing
815 mkReturnVector :: Unique
816 -> [(ConTag, AbstractC)] -- Branch codes
817 -> AbstractC -- Default case
818 -> SRT -- continuation's SRT
819 -> Liveness -- stack liveness
820 -> CtrlReturnConvention
823 mkReturnVector uniq tagged_alt_absCs deflt_absC srt liveness ret_conv
824 = getSRTInfo srt `thenFC` \ srt_info ->
826 (return_vec_amode, vtbl_body) = case ret_conv of {
828 -- might be a polymorphic case...
829 UnvectoredReturn 0 ->
830 ASSERT(null tagged_alt_absCs)
831 (CLbl ret_label RetRep,
832 absC (CRetDirect uniq deflt_absC srt_info liveness));
834 UnvectoredReturn n ->
835 -- find the tag explicitly rather than using tag_reg for now.
836 -- on architectures with lots of regs the tag will be loaded
837 -- into tag_reg by the code doing the returning.
839 tag = CMacroExpr WordRep GET_TAG [CVal (nodeRel 0) DataPtrRep]
841 (CLbl ret_label RetRep,
842 absC (CRetDirect uniq
843 (mkAlgAltsCSwitch tag tagged_alt_absCs deflt_absC)
847 VectoredReturn table_size ->
849 (vector_table, alts_absC) =
850 unzip (map mk_vector_entry [fIRST_TAG .. (table_size+fIRST_TAG-1)])
852 ret_vector = CRetVector vtbl_label vector_table srt_info liveness
854 (CLbl vtbl_label DataPtrRep,
855 -- alts come first, because we don't want to declare all the symbols
856 absC (mkAbstractCs (mkAbstractCs alts_absC : [deflt_absC,ret_vector]))
861 returnFC return_vec_amode
865 vtbl_label = mkVecTblLabel uniq
866 ret_label = mkReturnInfoLabel uniq
869 case nonemptyAbsC deflt_absC of
870 -- the simplifier might have eliminated a case
871 Nothing -> mkIntCLit 0 -- CLbl mkErrorStdEntryLabel CodePtrRep
872 Just absC@(CCodeBlock lbl _) -> CLbl lbl CodePtrRep
874 mk_vector_entry :: ConTag -> (CAddrMode, AbstractC)
876 = case [ absC | (t, absC) <- tagged_alt_absCs, t == tag ] of
877 [] -> (deflt_lbl, AbsCNop)
878 [absC@(CCodeBlock lbl _)] -> (CLbl lbl CodePtrRep,absC)
879 _ -> panic "mkReturnVector: too many"
882 %************************************************************************
884 \subsection[CgCase-utils]{Utilities for handling case expressions}
886 %************************************************************************
888 @possibleHeapCheck@ tests a flag passed in to decide whether to do a
889 heap check or not. These heap checks are always in a case
890 alternative, so we use altHeapCheck.
895 -> Bool -- True <=> polymorphic case
896 -> [MagicId] -- live registers
897 -> [(VirtualSpOffset,Int)] -- stack slots to tag
898 -> Maybe Unique -- return address unique
899 -> Code -- continuation
902 algAltHeapCheck GCMayHappen is_poly regs tags lbl code
903 = altHeapCheck is_poly False regs tags AbsCNop lbl code
904 algAltHeapCheck NoGC _ _ tags lbl code
907 primAltHeapCheck GCMayHappen regs tags lbl code
908 = altHeapCheck False True regs tags AbsCNop lbl code
909 primAltHeapCheck NoGC _ _ _ code