2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 % $Id: CgCase.lhs,v 1.54 2001/10/11 14:31:45 sewardj 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) `thenC`
160 -- NB: no liveness arg
162 } `thenFC` \ tag_amode ->
165 closure = CVal (CIndex (CLbl (mkClosureTblLabel tycon) PtrRep)
170 -- Bind the default binder if necessary
171 -- The deadness info is set by StgVarInfo
172 (if (isDeadBinder bndr)
174 else bindNewToTemp bndr `thenFC` \ bndr_amode ->
175 absC (CAssign bndr_amode closure))
179 cgAlgAlts NoGC (getUnique bndr) Nothing{-cc_slot-} False{-no semi-tagging-}
180 False{-not poly case-} alts deflt
181 False{-don't emit yield-} `thenFC` \ (tagged_alts, deflt_c) ->
184 absC (mkAlgAltsCSwitch tag_amode tagged_alts deflt_c)
187 Special case #2: inline PrimOps.
190 cgCase (StgOpApp op@(StgPrimOp primop) args _)
191 live_in_whole_case live_in_alts bndr srt alts
192 | not (primOpOutOfLine primop)
194 -- Get amodes for the arguments and results
195 getArgAmodes args `thenFC` \ arg_amodes ->
196 getVolatileRegs live_in_alts `thenFC` \ vol_regs ->
199 StgPrimAlts tycon alts deflt -- PRIMITIVE ALTS
200 -> absC (COpStmt [CTemp (getUnique bndr) (tyConPrimRep tycon)]
202 arg_amodes -- note: no liveness arg
204 cgPrimInlineAlts bndr tycon alts deflt
206 StgAlgAlts (Just tycon) [(_, args, _, rhs)] StgNoDefault
207 | isUnboxedTupleTyCon tycon -- UNBOXED TUPLE ALTS
208 -> -- no heap check, no yield, just get in there and do it.
209 absC (COpStmt [ CTemp (getUnique arg) (idPrimRep arg) | arg <- args ]
211 arg_amodes -- note: no liveness arg
213 mapFCs bindNewToTemp args `thenFC` \ _ ->
216 other -> pprPanic "cgCase: case of primop has strange alts" (pprStgAlts alts)
219 TODO: Case-of-case of primop can probably be done inline too (but
220 maybe better to translate it out beforehand). See
221 ghc/lib/misc/PackedString.lhs for examples where this crops up (with
224 Another special case: scrutinising a primitive-typed variable. No
225 evaluation required. We don't save volatile variables, nor do we do a
226 heap-check in the alternatives. Instead, the heap usage of the
227 alternatives is worst-cased and passed upstream. This can result in
228 allocating more heap than strictly necessary, but it will sometimes
229 eliminate a heap check altogether.
232 cgCase (StgApp v []) live_in_whole_case live_in_alts bndr srt
233 (StgPrimAlts tycon alts deflt)
236 getCAddrMode v `thenFC` \amode ->
239 Careful! we can't just bind the default binder to the same thing
240 as the scrutinee, since it might be a stack location, and having
241 two bindings pointing at the same stack locn doesn't work (it
242 confuses nukeDeadBindings). Hence, use a new temp.
244 bindNewToTemp bndr `thenFC` \deflt_amode ->
245 absC (CAssign deflt_amode amode) `thenC`
247 cgPrimAlts NoGC amode alts deflt []
250 Special case: scrutinising a non-primitive variable.
251 This can be done a little better than the general case, because
252 we can reuse/trim the stack slot holding the variable (if it is in one).
255 cgCase (StgApp fun args)
256 live_in_whole_case live_in_alts bndr srt alts
257 = getCAddrModeAndInfo fun `thenFC` \ (fun', fun_amode, lf_info) ->
258 getArgAmodes args `thenFC` \ arg_amodes ->
260 -- Squish the environment
261 nukeDeadBindings live_in_alts `thenC`
262 saveVolatileVarsAndRegs live_in_alts
263 `thenFC` \ (save_assts, alts_eob_info, maybe_cc_slot) ->
265 allocStackTop retPrimRepSize `thenFC` \_ ->
267 forkEval alts_eob_info nopC (
268 deAllocStackTop retPrimRepSize `thenFC` \_ ->
269 cgEvalAlts maybe_cc_slot bndr srt alts)
270 `thenFC` \ scrut_eob_info ->
272 setEndOfBlockInfo (maybeReserveSeqFrame alts scrut_eob_info) $
273 tailCallFun fun' fun_amode lf_info arg_amodes save_assts
276 Note about return addresses: we *always* push a return address, even
277 if because of an optimisation we end up jumping direct to the return
278 code (not through the address itself). The alternatives always assume
279 that the return address is on the stack. The return address is
280 required in case the alternative performs a heap check, since it
281 encodes the liveness of the slots in the activation record.
283 On entry to the case alternative, we can re-use the slot containing
284 the return address immediately after the heap check. That's what the
285 deAllocStackTop call is doing above.
287 Finally, here is the general case.
290 cgCase expr live_in_whole_case live_in_alts bndr srt alts
291 = -- Figure out what volatile variables to save
292 nukeDeadBindings live_in_whole_case `thenC`
294 saveVolatileVarsAndRegs live_in_alts
295 `thenFC` \ (save_assts, alts_eob_info, maybe_cc_slot) ->
297 -- Save those variables right now!
298 absC save_assts `thenC`
300 -- generate code for the alts
301 forkEval alts_eob_info
302 (nukeDeadBindings live_in_alts `thenC`
303 allocStackTop retPrimRepSize -- space for retn address
306 (deAllocStackTop retPrimRepSize `thenFC` \_ ->
307 cgEvalAlts maybe_cc_slot bndr srt alts) `thenFC` \ scrut_eob_info ->
309 setEndOfBlockInfo (maybeReserveSeqFrame alts scrut_eob_info) $
313 There's a lot of machinery going on behind the scenes to manage the
314 stack pointer here. forkEval takes the virtual Sp and free list from
315 the first argument, and turns that into the *real* Sp for the second
316 argument. It also uses this virtual Sp as the args-Sp in the EOB info
317 returned, so that the scrutinee will trim the real Sp back to the
318 right place before doing whatever it does.
319 --SDM (who just spent an hour figuring this out, and didn't want to
322 Why don't we push the return address just before evaluating the
323 scrutinee? Because the slot reserved for the return address might
324 contain something useful, so we wait until performing a tail call or
325 return before pushing the return address (see
326 CgTailCall.pushReturnAddress).
328 This also means that the environment doesn't need to know about the
329 free stack slot for the return address (for generating bitmaps),
330 because we don't reserve it until just before the eval.
332 TODO!! Problem: however, we have to save the current cost centre
333 stack somewhere, because at the eval point the current CCS might be
334 different. So we pick a free stack slot and save CCCS in it. The
335 problem with this is that this slot isn't recorded as free/unboxed in
336 the environment, so a case expression in the scrutinee will have the
337 wrong bitmap attached. Fortunately we don't ever seem to see
338 case-of-case at the back end. One solution might be to shift the
339 saved CCS to the correct place in the activation record just before
343 (one consequence of the above is that activation records on the stack
344 don't follow the layout of closures when we're profiling. The CCS
345 could be anywhere within the record).
348 -- We need to reserve a seq frame for a polymorphic case
349 maybeReserveSeqFrame (StgAlgAlts Nothing _ _) scrut_eob_info = reserveSeqFrame scrut_eob_info
350 maybeReserveSeqFrame other scrut_eob_info = scrut_eob_info
353 %************************************************************************
355 \subsection[CgCase-alts]{Alternatives}
357 %************************************************************************
359 @cgEvalAlts@ returns an addressing mode for a continuation for the
360 alternatives of a @case@, used in a context when there
361 is some evaluation to be done.
364 cgEvalAlts :: Maybe VirtualSpOffset -- Offset of cost-centre to be restored, if any
366 -> SRT -- SRT for the continuation
368 -> FCode Sequel -- Any addr modes inside are guaranteed
369 -- to be a label so that we can duplicate it
370 -- without risk of duplicating code
372 cgEvalAlts cc_slot bndr srt alts
374 let uniq = getUnique bndr in
376 buildContLivenessMask uniq `thenFC` \ liveness_mask ->
380 -- algebraic alts ...
381 StgAlgAlts maybe_tycon alts deflt ->
383 -- bind the default binder (it covers all the alternatives)
384 bindNewToReg bndr node mkLFArgument `thenC`
386 -- Generate sequel info for use downstream
387 -- At the moment, we only do it if the type is vector-returnable.
388 -- Reason: if not, then it costs extra to label the
389 -- alternatives, because we'd get return code like:
391 -- switch TagReg { 0 : JMP(alt_1); 1 : JMP(alt_2) ..etc }
393 -- which is worse than having the alt code in the switch statement
395 let is_alg = maybeToBool maybe_tycon
396 Just spec_tycon = maybe_tycon
399 -- Deal with the unboxed tuple case
400 if is_alg && isUnboxedTupleTyCon spec_tycon then
401 -- By now, the simplifier should have have turned it
402 -- into case e of (# a,b #) -> e
403 -- There shouldn't be a
404 -- case e of DEFAULT -> e
405 ASSERT2( case (alts, deflt) of { ([_],StgNoDefault) -> True; other -> False },
406 text "cgEvalAlts: dodgy case of unboxed tuple type" )
409 lbl = mkReturnInfoLabel uniq
411 cgUnboxedTupleAlt uniq cc_slot True alt `thenFC` \ abs_c ->
412 getSRTInfo srt `thenFC` \ srt_info ->
413 absC (CRetDirect uniq abs_c srt_info liveness_mask) `thenC`
414 returnFC (CaseAlts (CLbl lbl RetRep) Nothing)
416 -- normal algebraic (or polymorphic) case alternatives
418 ret_conv | is_alg = ctrlReturnConvAlg spec_tycon
419 | otherwise = UnvectoredReturn 0
421 use_labelled_alts = case ret_conv of
422 VectoredReturn _ -> True
426 = if use_labelled_alts then
427 cgSemiTaggedAlts bndr alts deflt -- Just <something>
429 Nothing -- no semi-tagging info
432 cgAlgAlts GCMayHappen uniq cc_slot use_labelled_alts (not is_alg)
433 alts deflt True `thenFC` \ (tagged_alt_absCs, deflt_absC) ->
435 mkReturnVector uniq tagged_alt_absCs deflt_absC srt liveness_mask
436 ret_conv `thenFC` \ return_vec ->
438 returnFC (CaseAlts return_vec semi_tagged_stuff)
441 StgPrimAlts tycon alts deflt ->
443 -- Restore the cost centre
444 restoreCurrentCostCentre cc_slot `thenFC` \ cc_restore ->
446 -- Generate the switch
447 getAbsC (cgPrimEvalAlts bndr tycon alts deflt) `thenFC` \ abs_c ->
449 -- Generate the labelled block, starting with restore-cost-centre
450 getSRTInfo srt `thenFC` \srt_info ->
451 absC (CRetDirect uniq (cc_restore `mkAbsCStmts` abs_c)
452 srt_info liveness_mask) `thenC`
454 -- Return an amode for the block
455 returnFC (CaseAlts (CLbl (mkReturnInfoLabel uniq) RetRep) Nothing)
459 HWL comment on {\em GrAnSim\/} (adding GRAN_YIELDs for context switch): If
460 we do an inlining of the case no separate functions for returning are
461 created, so we don't have to generate a GRAN_YIELD in that case. This info
462 must be propagated to cgAlgAltRhs (where the GRAN_YIELD macro might be
463 emitted). Hence, the new Bool arg to cgAlgAltRhs.
465 %************************************************************************
467 \subsection[CgCase-alg-alts]{Algebraic alternatives}
469 %************************************************************************
471 In @cgAlgAlts@, none of the binders in the alternatives are
472 assumed to be yet bound.
474 HWL comment on {\em GrAnSim\/} (adding GRAN_YIELDs for context switch): The
475 last arg of cgAlgAlts indicates if we want a context switch at the
476 beginning of each alternative. Normally we want that. The only exception
477 are inlined alternatives.
482 -> Maybe VirtualSpOffset
483 -> Bool -- True <=> branches must be labelled
484 -> Bool -- True <=> polymorphic case
485 -> [(DataCon, [Id], [Bool], StgExpr)] -- The alternatives
486 -> StgCaseDefault -- The default
487 -> Bool -- Context switch at alts?
488 -> FCode ([(ConTag, AbstractC)], -- The branches
489 AbstractC -- The default case
492 cgAlgAlts gc_flag uniq restore_cc must_label_branches is_fun alts deflt
493 emit_yield{-should a yield macro be emitted?-}
495 = forkAlts (map (cgAlgAlt gc_flag uniq restore_cc must_label_branches emit_yield) alts)
496 (cgAlgDefault gc_flag is_fun uniq restore_cc must_label_branches deflt emit_yield)
500 cgAlgDefault :: GCFlag
501 -> Bool -- could be a function-typed result?
502 -> Unique -> Maybe VirtualSpOffset -> Bool -- turgid state...
503 -> StgCaseDefault -- input
505 -> FCode AbstractC -- output
507 cgAlgDefault gc_flag is_fun uniq cc_slot must_label_branch StgNoDefault _
510 cgAlgDefault gc_flag is_fun uniq cc_slot must_label_branch
512 emit_yield{-should a yield macro be emitted?-}
514 = -- We have arranged that Node points to the thing
515 restoreCurrentCostCentre cc_slot `thenFC` \restore_cc ->
516 getAbsC (absC restore_cc `thenC`
517 -- HWL: maybe need yield here
519 -- then yield [node] True
520 -- else absC AbsCNop) `thenC`
521 possibleHeapCheck gc_flag is_fun [node] [] Nothing (cgExpr rhs)
522 -- Node is live, but doesn't need to point at the thing itself;
523 -- it's ok for Node to point to an indirection or FETCH_ME
524 -- Hence no need to re-enter Node.
525 ) `thenFC` \ abs_c ->
528 final_abs_c | must_label_branch = CCodeBlock lbl abs_c
533 lbl = mkDefaultLabel uniq
535 -- HWL comment on GrAnSim: GRAN_YIELDs needed; emitted in cgAlgAltRhs
538 -> Unique -> Maybe VirtualSpOffset -> Bool -- turgid state
539 -> Bool -- Context switch at alts?
540 -> (DataCon, [Id], [Bool], StgExpr)
541 -> FCode (ConTag, AbstractC)
543 cgAlgAlt gc_flag uniq cc_slot must_label_branch
544 emit_yield{-should a yield macro be emitted?-}
545 (con, args, use_mask, rhs)
547 restoreCurrentCostCentre cc_slot `thenFC` \restore_cc ->
548 getAbsC (absC restore_cc `thenC`
549 -- HWL: maybe need yield here
551 -- then yield [node] True -- XXX live regs wrong
552 -- else absC AbsCNop) `thenC`
554 NoGC -> mapFCs bindNewToTemp args `thenFC` \_ -> nopC
555 GCMayHappen -> bindConArgs con args
557 possibleHeapCheck gc_flag False [node] [] Nothing (
559 ) `thenFC` \ abs_c ->
561 final_abs_c | must_label_branch = CCodeBlock lbl abs_c
564 returnFC (tag, final_abs_c)
567 lbl = mkAltLabel uniq tag
570 :: Unique -- unique for label of the alternative
571 -> Maybe VirtualSpOffset -- Restore cost centre
572 -> Bool -- ctxt switch
573 -> (DataCon, [Id], [Bool], StgExpr) -- alternative
576 cgUnboxedTupleAlt lbl cc_slot emit_yield (con,args,use_mask,rhs)
578 bindUnboxedTupleComponents args
579 `thenFC` \ (live_regs,tags,stack_res) ->
581 restoreCurrentCostCentre cc_slot `thenFC` \restore_cc ->
582 absC restore_cc `thenC`
584 -- HWL: maybe need yield here
586 -- then yield live_regs True -- XXX live regs wrong?
587 -- else absC AbsCNop) `thenC`
589 -- ToDo: could maybe use Nothing here if stack_res is False
590 -- since the heap-check can just return to the top of the
595 -- free up stack slots containing tags,
596 freeStackSlots (map fst tags) `thenC`
598 -- generate a heap check if necessary
599 possibleHeapCheck GCMayHappen False live_regs tags ret_addr (
601 -- and finally the code for the alternative
606 %************************************************************************
608 \subsection[CgCase-semi-tagged-alts]{The code to deal with sem-tagging}
610 %************************************************************************
612 Turgid-but-non-monadic code to conjure up the required info from
613 algebraic case alternatives for semi-tagging.
616 cgSemiTaggedAlts :: Id
617 -> [(DataCon, [Id], [Bool], StgExpr)]
618 -> GenStgCaseDefault Id Id
621 cgSemiTaggedAlts binder alts deflt
622 = Just (map st_alt alts, st_deflt deflt)
624 uniq = getUnique binder
626 st_deflt StgNoDefault = Nothing
628 st_deflt (StgBindDefault _)
630 (CCallProfCtrMacro SLIT("RET_SEMI_BY_DEFAULT") [], -- ToDo: monadise?
634 st_alt (con, args, use_mask, _)
635 = -- Ha! Nothing to do; Node already points to the thing
637 (CCallProfCtrMacro SLIT("RET_SEMI_IN_HEAP") -- ToDo: monadise?
638 [mkIntCLit (length args)], -- how big the thing in the heap is
642 con_tag = dataConTag con
643 join_label = mkAltLabel uniq con_tag
646 %************************************************************************
648 \subsection[CgCase-prim-alts]{Primitive alternatives}
650 %************************************************************************
652 @cgPrimEvalAlts@ and @cgPrimInlineAlts@ generate suitable @CSwitch@es
653 for dealing with the alternatives of a primitive @case@, given an
654 addressing mode for the thing to scrutinise. It also keeps track of
655 the maximum stack depth encountered down any branch.
657 As usual, no binders in the alternatives are yet bound.
660 cgPrimInlineAlts bndr tycon alts deflt
661 = cgPrimAltsWithDefault bndr NoGC (CTemp uniq kind) alts deflt []
663 uniq = getUnique bndr
664 kind = tyConPrimRep tycon
666 cgPrimEvalAlts bndr tycon alts deflt
667 = cgPrimAltsWithDefault bndr GCMayHappen (CReg reg) alts deflt [reg]
669 reg = WARN( case kind of { PtrRep -> True; other -> False },
670 text "cgPrimEE" <+> ppr bndr <+> ppr tycon )
671 dataReturnConvPrim kind
672 kind = tyConPrimRep tycon
674 cgPrimAltsWithDefault bndr gc_flag scrutinee alts deflt regs
675 = -- first bind the default if necessary
676 bindNewPrimToAmode bndr scrutinee `thenC`
677 cgPrimAlts gc_flag scrutinee alts deflt regs
679 cgPrimAlts gc_flag scrutinee alts deflt regs
680 = forkAlts (map (cgPrimAlt gc_flag regs) alts)
681 (cgPrimDefault gc_flag regs deflt)
682 `thenFC` \ (alt_absCs, deflt_absC) ->
684 absC (CSwitch scrutinee alt_absCs deflt_absC)
685 -- CSwitch does sensible things with one or zero alternatives
689 -> [MagicId] -- live registers
690 -> (Literal, StgExpr) -- The alternative
691 -> FCode (Literal, AbstractC) -- Its compiled form
693 cgPrimAlt gc_flag regs (lit, rhs)
694 = getAbsC rhs_code `thenFC` \ absC ->
697 rhs_code = possibleHeapCheck gc_flag False regs [] Nothing (cgExpr rhs)
699 cgPrimDefault :: GCFlag
700 -> [MagicId] -- live registers
704 cgPrimDefault gc_flag regs StgNoDefault
705 = panic "cgPrimDefault: No default in prim case"
707 cgPrimDefault gc_flag regs (StgBindDefault rhs)
708 = getAbsC (possibleHeapCheck gc_flag False regs [] Nothing (cgExpr rhs))
712 %************************************************************************
714 \subsection[CgCase-tidy]{Code for tidying up prior to an eval}
716 %************************************************************************
719 saveVolatileVarsAndRegs
720 :: StgLiveVars -- Vars which should be made safe
721 -> FCode (AbstractC, -- Assignments to do the saves
722 EndOfBlockInfo, -- sequel for the alts
723 Maybe VirtualSpOffset) -- Slot for current cost centre
726 saveVolatileVarsAndRegs vars
727 = saveVolatileVars vars `thenFC` \ var_saves ->
728 saveCurrentCostCentre `thenFC` \ (maybe_cc_slot, cc_save) ->
729 getEndOfBlockInfo `thenFC` \ eob_info ->
730 returnFC (mkAbstractCs [var_saves, cc_save],
735 saveVolatileVars :: StgLiveVars -- Vars which should be made safe
736 -> FCode AbstractC -- Assignments to to the saves
738 saveVolatileVars vars
739 = save_em (varSetElems vars)
741 save_em [] = returnFC AbsCNop
744 = getCAddrModeIfVolatile var `thenFC` \ v ->
746 Nothing -> save_em vars -- Non-volatile, so carry on
749 Just vol_amode -> -- Aha! It's volatile
750 save_var var vol_amode `thenFC` \ abs_c ->
751 save_em vars `thenFC` \ abs_cs ->
752 returnFC (abs_c `mkAbsCStmts` abs_cs)
754 save_var var vol_amode
755 = allocPrimStack (getPrimRepSize kind) `thenFC` \ slot ->
756 rebindToStack var slot `thenC`
757 getSpRelOffset slot `thenFC` \ sp_rel ->
758 returnFC (CAssign (CVal sp_rel kind) vol_amode)
760 kind = getAmodeRep vol_amode
763 ---------------------------------------------------------------------------
765 When we save the current cost centre (which is done for lexical
766 scoping), we allocate a free stack location, and return (a)~the
767 virtual offset of the location, to pass on to the alternatives, and
768 (b)~the assignment to do the save (just as for @saveVolatileVars@).
771 saveCurrentCostCentre ::
772 FCode (Maybe VirtualSpOffset, -- Where we decide to store it
773 AbstractC) -- Assignment to save it
775 saveCurrentCostCentre
776 = if not opt_SccProfilingOn then
777 returnFC (Nothing, AbsCNop)
779 allocPrimStack (getPrimRepSize CostCentreRep) `thenFC` \ slot ->
780 dataStackSlots [slot] `thenC`
781 getSpRelOffset slot `thenFC` \ sp_rel ->
783 CAssign (CVal sp_rel CostCentreRep) (CReg CurCostCentre))
785 restoreCurrentCostCentre :: Maybe VirtualSpOffset -> FCode AbstractC
786 restoreCurrentCostCentre Nothing = returnFC AbsCNop
787 restoreCurrentCostCentre (Just slot)
788 = getSpRelOffset slot `thenFC` \ sp_rel ->
789 freeStackSlots [slot] `thenC`
790 returnFC (CCallProfCCMacro SLIT("RESTORE_CCCS") [CVal sp_rel CostCentreRep])
791 -- we use the RESTORE_CCCS macro, rather than just
792 -- assigning into CurCostCentre, in case RESTORE_CCCS
793 -- has some sanity-checking in it.
796 %************************************************************************
798 \subsection[CgCase-return-vec]{Building a return vector}
800 %************************************************************************
802 Build a return vector, and return a suitable label addressing
806 mkReturnVector :: Unique
807 -> [(ConTag, AbstractC)] -- Branch codes
808 -> AbstractC -- Default case
809 -> SRT -- continuation's SRT
810 -> Liveness -- stack liveness
811 -> CtrlReturnConvention
814 mkReturnVector uniq tagged_alt_absCs deflt_absC srt liveness ret_conv
815 = getSRTInfo srt `thenFC` \ srt_info ->
817 (return_vec_amode, vtbl_body) = case ret_conv of {
819 -- might be a polymorphic case...
820 UnvectoredReturn 0 ->
821 ASSERT(null tagged_alt_absCs)
822 (CLbl ret_label RetRep,
823 absC (CRetDirect uniq deflt_absC srt_info liveness));
825 UnvectoredReturn n ->
826 -- find the tag explicitly rather than using tag_reg for now.
827 -- on architectures with lots of regs the tag will be loaded
828 -- into tag_reg by the code doing the returning.
830 tag = CMacroExpr WordRep GET_TAG [CVal (nodeRel 0) DataPtrRep]
832 (CLbl ret_label RetRep,
833 absC (CRetDirect uniq
834 (mkAlgAltsCSwitch tag tagged_alt_absCs deflt_absC)
838 VectoredReturn table_size ->
840 (vector_table, alts_absC) =
841 unzip (map mk_vector_entry [fIRST_TAG .. (table_size+fIRST_TAG-1)])
843 ret_vector = CRetVector vtbl_label vector_table srt_info liveness
845 (CLbl vtbl_label DataPtrRep,
846 -- alts come first, because we don't want to declare all the symbols
847 absC (mkAbstractCs (mkAbstractCs alts_absC : [deflt_absC,ret_vector]))
852 returnFC return_vec_amode
856 vtbl_label = mkVecTblLabel uniq
857 ret_label = mkReturnInfoLabel uniq
860 case nonemptyAbsC deflt_absC of
861 -- the simplifier might have eliminated a case
862 Nothing -> mkIntCLit 0 -- CLbl mkErrorStdEntryLabel CodePtrRep
863 Just absC@(CCodeBlock lbl _) -> CLbl lbl CodePtrRep
865 mk_vector_entry :: ConTag -> (CAddrMode, AbstractC)
867 = case [ absC | (t, absC) <- tagged_alt_absCs, t == tag ] of
868 [] -> (deflt_lbl, AbsCNop)
869 [absC@(CCodeBlock lbl _)] -> (CLbl lbl CodePtrRep,absC)
870 _ -> panic "mkReturnVector: too many"
873 %************************************************************************
875 \subsection[CgCase-utils]{Utilities for handling case expressions}
877 %************************************************************************
879 @possibleHeapCheck@ tests a flag passed in to decide whether to do a
880 heap check or not. These heap checks are always in a case
881 alternative, so we use altHeapCheck.
886 -> Bool -- True <=> algebraic case
887 -> [MagicId] -- live registers
888 -> [(VirtualSpOffset,Int)] -- stack slots to tag
889 -> Maybe Unique -- return address unique
890 -> Code -- continuation
893 possibleHeapCheck GCMayHappen is_alg regs tags lbl code
894 = altHeapCheck is_alg regs tags AbsCNop lbl code
895 possibleHeapCheck NoGC _ _ tags lbl code