2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 % $Id: CgCase.lhs,v 1.51 2000/12/06 13:19:49 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 (StgPrimApp 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 ->
150 let tag_amode = case op of
151 TagToEnumOp -> only arg_amodes
152 _ -> CTemp (newTagUnique (getUnique bndr) 'C') IntRep
154 closure = CVal (CIndex (CLbl (mkClosureTblLabel tycon) PtrRep) tag_amode PtrRep) PtrRep
158 TagToEnumOp -> nopC; -- no code!
160 _ -> -- Perform the operation
161 getVolatileRegs live_in_alts `thenFC` \ vol_regs ->
163 absC (COpStmt [tag_amode] op
164 arg_amodes -- note: no liveness arg
168 -- bind the default binder if necessary
169 -- The deadness info is set by StgVarInfo
170 (if (isDeadBinder bndr)
172 else bindNewToTemp bndr `thenFC` \ bndr_amode ->
173 absC (CAssign bndr_amode closure))
177 cgAlgAlts NoGC (getUnique bndr) Nothing{-cc_slot-} False{-no semi-tagging-}
178 False{-not poly case-} alts deflt
179 False{-don't emit yield-} `thenFC` \ (tagged_alts, deflt_c) ->
182 absC (mkAlgAltsCSwitch tag_amode tagged_alts deflt_c)
185 Special case #2: inline PrimOps.
188 cgCase (StgPrimApp op args _)
189 live_in_whole_case live_in_alts bndr srt alts
190 | not (primOpOutOfLine op)
192 -- Get amodes for the arguments and results
193 getArgAmodes args `thenFC` \ arg_amodes ->
194 getVolatileRegs live_in_alts `thenFC` \ vol_regs ->
197 StgPrimAlts tycon alts deflt -- PRIMITIVE ALTS
198 -> absC (COpStmt [CTemp (getUnique bndr) (tyConPrimRep tycon)]
200 arg_amodes -- note: no liveness arg
202 cgPrimInlineAlts bndr tycon alts deflt
204 StgAlgAlts (Just tycon) [(_, args, _, rhs)] StgNoDefault
205 | isUnboxedTupleTyCon tycon -- UNBOXED TUPLE ALTS
206 -> -- no heap check, no yield, just get in there and do it.
207 absC (COpStmt [ CTemp (getUnique arg) (idPrimRep arg) | arg <- args ]
209 arg_amodes -- note: no liveness arg
211 mapFCs bindNewToTemp args `thenFC` \ _ ->
214 other -> pprPanic "cgCase: case of primop has strange alts" (pprStgAlts alts)
217 TODO: Case-of-case of primop can probably be done inline too (but
218 maybe better to translate it out beforehand). See
219 ghc/lib/misc/PackedString.lhs for examples where this crops up (with
222 Another special case: scrutinising a primitive-typed variable. No
223 evaluation required. We don't save volatile variables, nor do we do a
224 heap-check in the alternatives. Instead, the heap usage of the
225 alternatives is worst-cased and passed upstream. This can result in
226 allocating more heap than strictly necessary, but it will sometimes
227 eliminate a heap check altogether.
230 cgCase (StgApp v []) live_in_whole_case live_in_alts bndr srt
231 (StgPrimAlts tycon alts deflt)
234 getCAddrMode v `thenFC` \amode ->
237 Careful! we can't just bind the default binder to the same thing
238 as the scrutinee, since it might be a stack location, and having
239 two bindings pointing at the same stack locn doesn't work (it
240 confuses nukeDeadBindings). Hence, use a new temp.
242 bindNewToTemp bndr `thenFC` \deflt_amode ->
243 absC (CAssign deflt_amode amode) `thenC`
245 cgPrimAlts NoGC amode alts deflt []
248 Special case: scrutinising a non-primitive variable.
249 This can be done a little better than the general case, because
250 we can reuse/trim the stack slot holding the variable (if it is in one).
253 cgCase (StgApp fun args)
254 live_in_whole_case live_in_alts bndr srt alts
255 = getCAddrModeAndInfo fun `thenFC` \ (fun', fun_amode, lf_info) ->
256 getArgAmodes args `thenFC` \ arg_amodes ->
258 -- Squish the environment
259 nukeDeadBindings live_in_alts `thenC`
260 saveVolatileVarsAndRegs live_in_alts
261 `thenFC` \ (save_assts, alts_eob_info, maybe_cc_slot) ->
263 allocStackTop retPrimRepSize `thenFC` \_ ->
265 forkEval alts_eob_info nopC (
266 deAllocStackTop retPrimRepSize `thenFC` \_ ->
267 cgEvalAlts maybe_cc_slot bndr srt alts)
268 `thenFC` \ scrut_eob_info ->
270 setEndOfBlockInfo (maybeReserveSeqFrame alts scrut_eob_info) $
271 tailCallFun fun' fun_amode lf_info arg_amodes save_assts
274 Note about return addresses: we *always* push a return address, even
275 if because of an optimisation we end up jumping direct to the return
276 code (not through the address itself). The alternatives always assume
277 that the return address is on the stack. The return address is
278 required in case the alternative performs a heap check, since it
279 encodes the liveness of the slots in the activation record.
281 On entry to the case alternative, we can re-use the slot containing
282 the return address immediately after the heap check. That's what the
283 deAllocStackTop call is doing above.
285 Finally, here is the general case.
288 cgCase expr live_in_whole_case live_in_alts bndr srt alts
289 = -- Figure out what volatile variables to save
290 nukeDeadBindings live_in_whole_case `thenC`
292 saveVolatileVarsAndRegs live_in_alts
293 `thenFC` \ (save_assts, alts_eob_info, maybe_cc_slot) ->
295 -- Save those variables right now!
296 absC save_assts `thenC`
298 -- generate code for the alts
299 forkEval alts_eob_info
300 (nukeDeadBindings live_in_alts `thenC`
301 allocStackTop retPrimRepSize -- space for retn address
304 (deAllocStackTop retPrimRepSize `thenFC` \_ ->
305 cgEvalAlts maybe_cc_slot bndr srt alts) `thenFC` \ scrut_eob_info ->
307 setEndOfBlockInfo (maybeReserveSeqFrame alts scrut_eob_info) $
311 There's a lot of machinery going on behind the scenes to manage the
312 stack pointer here. forkEval takes the virtual Sp and free list from
313 the first argument, and turns that into the *real* Sp for the second
314 argument. It also uses this virtual Sp as the args-Sp in the EOB info
315 returned, so that the scrutinee will trim the real Sp back to the
316 right place before doing whatever it does.
317 --SDM (who just spent an hour figuring this out, and didn't want to
320 Why don't we push the return address just before evaluating the
321 scrutinee? Because the slot reserved for the return address might
322 contain something useful, so we wait until performing a tail call or
323 return before pushing the return address (see
324 CgTailCall.pushReturnAddress).
326 This also means that the environment doesn't need to know about the
327 free stack slot for the return address (for generating bitmaps),
328 because we don't reserve it until just before the eval.
330 TODO!! Problem: however, we have to save the current cost centre
331 stack somewhere, because at the eval point the current CCS might be
332 different. So we pick a free stack slot and save CCCS in it. The
333 problem with this is that this slot isn't recorded as free/unboxed in
334 the environment, so a case expression in the scrutinee will have the
335 wrong bitmap attached. Fortunately we don't ever seem to see
336 case-of-case at the back end. One solution might be to shift the
337 saved CCS to the correct place in the activation record just before
341 (one consequence of the above is that activation records on the stack
342 don't follow the layout of closures when we're profiling. The CCS
343 could be anywhere within the record).
346 -- We need to reserve a seq frame for a polymorphic case
347 maybeReserveSeqFrame (StgAlgAlts Nothing _ _) scrut_eob_info = reserveSeqFrame scrut_eob_info
348 maybeReserveSeqFrame other scrut_eob_info = scrut_eob_info
351 %************************************************************************
353 \subsection[CgCase-alts]{Alternatives}
355 %************************************************************************
357 @cgEvalAlts@ returns an addressing mode for a continuation for the
358 alternatives of a @case@, used in a context when there
359 is some evaluation to be done.
362 cgEvalAlts :: Maybe VirtualSpOffset -- Offset of cost-centre to be restored, if any
364 -> SRT -- SRT for the continuation
366 -> FCode Sequel -- Any addr modes inside are guaranteed
367 -- to be a label so that we can duplicate it
368 -- without risk of duplicating code
370 cgEvalAlts cc_slot bndr srt alts
372 let uniq = getUnique bndr in
374 buildContLivenessMask uniq `thenFC` \ liveness_mask ->
378 -- algebraic alts ...
379 StgAlgAlts maybe_tycon alts deflt ->
381 -- bind the default binder (it covers all the alternatives)
382 bindNewToReg bndr node mkLFArgument `thenC`
384 -- Generate sequel info for use downstream
385 -- At the moment, we only do it if the type is vector-returnable.
386 -- Reason: if not, then it costs extra to label the
387 -- alternatives, because we'd get return code like:
389 -- switch TagReg { 0 : JMP(alt_1); 1 : JMP(alt_2) ..etc }
391 -- which is worse than having the alt code in the switch statement
393 let is_alg = maybeToBool maybe_tycon
394 Just spec_tycon = maybe_tycon
397 -- deal with the unboxed tuple case
398 if is_alg && isUnboxedTupleTyCon spec_tycon then
400 [alt] -> let lbl = mkReturnInfoLabel uniq in
401 cgUnboxedTupleAlt uniq cc_slot True alt
403 getSRTLabel `thenFC` \srt_label ->
404 absC (CRetDirect uniq abs_c (srt_label, srt)
405 liveness_mask) `thenC`
406 returnFC (CaseAlts (CLbl lbl RetRep) Nothing)
407 _ -> panic "cgEvalAlts: dodgy case of unboxed tuple type"
409 -- normal algebraic (or polymorphic) case alternatives
411 ret_conv | is_alg = ctrlReturnConvAlg spec_tycon
412 | otherwise = UnvectoredReturn 0
414 use_labelled_alts = case ret_conv of
415 VectoredReturn _ -> True
419 = if use_labelled_alts then
420 cgSemiTaggedAlts bndr alts deflt -- Just <something>
422 Nothing -- no semi-tagging info
425 cgAlgAlts GCMayHappen uniq cc_slot use_labelled_alts (not is_alg)
426 alts deflt True `thenFC` \ (tagged_alt_absCs, deflt_absC) ->
428 mkReturnVector uniq tagged_alt_absCs deflt_absC srt liveness_mask
429 ret_conv `thenFC` \ return_vec ->
431 returnFC (CaseAlts return_vec semi_tagged_stuff)
434 StgPrimAlts tycon alts deflt ->
436 -- Restore the cost centre
437 restoreCurrentCostCentre cc_slot `thenFC` \ cc_restore ->
439 -- Generate the switch
440 getAbsC (cgPrimEvalAlts bndr tycon alts deflt) `thenFC` \ abs_c ->
442 -- Generate the labelled block, starting with restore-cost-centre
443 getSRTLabel `thenFC` \srt_label ->
444 absC (CRetDirect uniq (cc_restore `mkAbsCStmts` abs_c)
445 (srt_label,srt) liveness_mask) `thenC`
447 -- Return an amode for the block
448 returnFC (CaseAlts (CLbl (mkReturnInfoLabel uniq) RetRep) Nothing)
452 HWL comment on {\em GrAnSim\/} (adding GRAN_YIELDs for context switch): If
453 we do an inlining of the case no separate functions for returning are
454 created, so we don't have to generate a GRAN_YIELD in that case. This info
455 must be propagated to cgAlgAltRhs (where the GRAN_YIELD macro might be
456 emitted). Hence, the new Bool arg to cgAlgAltRhs.
458 %************************************************************************
460 \subsection[CgCase-alg-alts]{Algebraic alternatives}
462 %************************************************************************
464 In @cgAlgAlts@, none of the binders in the alternatives are
465 assumed to be yet bound.
467 HWL comment on {\em GrAnSim\/} (adding GRAN_YIELDs for context switch): The
468 last arg of cgAlgAlts indicates if we want a context switch at the
469 beginning of each alternative. Normally we want that. The only exception
470 are inlined alternatives.
475 -> Maybe VirtualSpOffset
476 -> Bool -- True <=> branches must be labelled
477 -> Bool -- True <=> polymorphic case
478 -> [(DataCon, [Id], [Bool], StgExpr)] -- The alternatives
479 -> StgCaseDefault -- The default
480 -> Bool -- Context switch at alts?
481 -> FCode ([(ConTag, AbstractC)], -- The branches
482 AbstractC -- The default case
485 cgAlgAlts gc_flag uniq restore_cc must_label_branches is_fun alts deflt
486 emit_yield{-should a yield macro be emitted?-}
488 = forkAlts (map (cgAlgAlt gc_flag uniq restore_cc must_label_branches emit_yield) alts)
489 (cgAlgDefault gc_flag is_fun uniq restore_cc must_label_branches deflt emit_yield)
493 cgAlgDefault :: GCFlag
494 -> Bool -- could be a function-typed result?
495 -> Unique -> Maybe VirtualSpOffset -> Bool -- turgid state...
496 -> StgCaseDefault -- input
498 -> FCode AbstractC -- output
500 cgAlgDefault gc_flag is_fun uniq cc_slot must_label_branch StgNoDefault _
503 cgAlgDefault gc_flag is_fun uniq cc_slot must_label_branch
505 emit_yield{-should a yield macro be emitted?-}
507 = -- We have arranged that Node points to the thing
508 restoreCurrentCostCentre cc_slot `thenFC` \restore_cc ->
509 getAbsC (absC restore_cc `thenC`
510 -- HWL: maybe need yield here
512 -- then yield [node] True
513 -- else absC AbsCNop) `thenC`
514 possibleHeapCheck gc_flag is_fun [node] [] Nothing (cgExpr rhs)
515 -- Node is live, but doesn't need to point at the thing itself;
516 -- it's ok for Node to point to an indirection or FETCH_ME
517 -- Hence no need to re-enter Node.
518 ) `thenFC` \ abs_c ->
521 final_abs_c | must_label_branch = CCodeBlock lbl abs_c
526 lbl = mkDefaultLabel uniq
528 -- HWL comment on GrAnSim: GRAN_YIELDs needed; emitted in cgAlgAltRhs
531 -> Unique -> Maybe VirtualSpOffset -> Bool -- turgid state
532 -> Bool -- Context switch at alts?
533 -> (DataCon, [Id], [Bool], StgExpr)
534 -> FCode (ConTag, AbstractC)
536 cgAlgAlt gc_flag uniq cc_slot must_label_branch
537 emit_yield{-should a yield macro be emitted?-}
538 (con, args, use_mask, rhs)
540 restoreCurrentCostCentre cc_slot `thenFC` \restore_cc ->
541 getAbsC (absC restore_cc `thenC`
542 -- HWL: maybe need yield here
544 -- then yield [node] True -- XXX live regs wrong
545 -- else absC AbsCNop) `thenC`
547 NoGC -> mapFCs bindNewToTemp args `thenFC` \_ -> nopC
548 GCMayHappen -> bindConArgs con args
550 possibleHeapCheck gc_flag False [node] [] Nothing (
552 ) `thenFC` \ abs_c ->
554 final_abs_c | must_label_branch = CCodeBlock lbl abs_c
557 returnFC (tag, final_abs_c)
560 lbl = mkAltLabel uniq tag
563 :: Unique -- unique for label of the alternative
564 -> Maybe VirtualSpOffset -- Restore cost centre
565 -> Bool -- ctxt switch
566 -> (DataCon, [Id], [Bool], StgExpr) -- alternative
569 cgUnboxedTupleAlt lbl cc_slot emit_yield (con,args,use_mask,rhs)
571 bindUnboxedTupleComponents args
572 `thenFC` \ (live_regs,tags,stack_res) ->
574 restoreCurrentCostCentre cc_slot `thenFC` \restore_cc ->
575 absC restore_cc `thenC`
577 -- HWL: maybe need yield here
579 -- then yield live_regs True -- XXX live regs wrong?
580 -- else absC AbsCNop) `thenC`
582 -- ToDo: could maybe use Nothing here if stack_res is False
583 -- since the heap-check can just return to the top of the
588 -- free up stack slots containing tags,
589 freeStackSlots (map fst tags) `thenC`
591 -- generate a heap check if necessary
592 possibleHeapCheck GCMayHappen False live_regs tags ret_addr (
594 -- and finally the code for the alternative
599 %************************************************************************
601 \subsection[CgCase-semi-tagged-alts]{The code to deal with sem-tagging}
603 %************************************************************************
605 Turgid-but-non-monadic code to conjure up the required info from
606 algebraic case alternatives for semi-tagging.
609 cgSemiTaggedAlts :: Id
610 -> [(DataCon, [Id], [Bool], StgExpr)]
611 -> GenStgCaseDefault Id Id
614 cgSemiTaggedAlts binder alts deflt
615 = Just (map st_alt alts, st_deflt deflt)
617 uniq = getUnique binder
619 st_deflt StgNoDefault = Nothing
621 st_deflt (StgBindDefault _)
623 (CCallProfCtrMacro SLIT("RET_SEMI_BY_DEFAULT") [], -- ToDo: monadise?
627 st_alt (con, args, use_mask, _)
628 = -- Ha! Nothing to do; Node already points to the thing
630 (CCallProfCtrMacro SLIT("RET_SEMI_IN_HEAP") -- ToDo: monadise?
631 [mkIntCLit (length args)], -- how big the thing in the heap is
635 con_tag = dataConTag con
636 join_label = mkAltLabel uniq con_tag
639 %************************************************************************
641 \subsection[CgCase-prim-alts]{Primitive alternatives}
643 %************************************************************************
645 @cgPrimEvalAlts@ and @cgPrimInlineAlts@ generate suitable @CSwitch@es
646 for dealing with the alternatives of a primitive @case@, given an
647 addressing mode for the thing to scrutinise. It also keeps track of
648 the maximum stack depth encountered down any branch.
650 As usual, no binders in the alternatives are yet bound.
653 cgPrimInlineAlts bndr tycon alts deflt
654 = cgPrimAltsWithDefault bndr NoGC (CTemp uniq kind) alts deflt []
656 uniq = getUnique bndr
657 kind = tyConPrimRep tycon
659 cgPrimEvalAlts bndr tycon alts deflt
660 = cgPrimAltsWithDefault bndr GCMayHappen (CReg reg) alts deflt [reg]
662 reg = WARN( case kind of { PtrRep -> True; other -> False },
663 text "cgPrimEE" <+> ppr bndr <+> ppr tycon )
664 dataReturnConvPrim kind
665 kind = tyConPrimRep tycon
667 cgPrimAltsWithDefault bndr gc_flag scrutinee alts deflt regs
668 = -- first bind the default if necessary
669 bindNewPrimToAmode bndr scrutinee `thenC`
670 cgPrimAlts gc_flag scrutinee alts deflt regs
672 cgPrimAlts gc_flag scrutinee alts deflt regs
673 = forkAlts (map (cgPrimAlt gc_flag regs) alts)
674 (cgPrimDefault gc_flag regs deflt)
675 `thenFC` \ (alt_absCs, deflt_absC) ->
677 absC (CSwitch scrutinee alt_absCs deflt_absC)
678 -- CSwitch does sensible things with one or zero alternatives
682 -> [MagicId] -- live registers
683 -> (Literal, StgExpr) -- The alternative
684 -> FCode (Literal, AbstractC) -- Its compiled form
686 cgPrimAlt gc_flag regs (lit, rhs)
687 = getAbsC rhs_code `thenFC` \ absC ->
690 rhs_code = possibleHeapCheck gc_flag False regs [] Nothing (cgExpr rhs)
692 cgPrimDefault :: GCFlag
693 -> [MagicId] -- live registers
697 cgPrimDefault gc_flag regs StgNoDefault
698 = panic "cgPrimDefault: No default in prim case"
700 cgPrimDefault gc_flag regs (StgBindDefault rhs)
701 = getAbsC (possibleHeapCheck gc_flag False regs [] Nothing (cgExpr rhs))
705 %************************************************************************
707 \subsection[CgCase-tidy]{Code for tidying up prior to an eval}
709 %************************************************************************
712 saveVolatileVarsAndRegs
713 :: StgLiveVars -- Vars which should be made safe
714 -> FCode (AbstractC, -- Assignments to do the saves
715 EndOfBlockInfo, -- sequel for the alts
716 Maybe VirtualSpOffset) -- Slot for current cost centre
719 saveVolatileVarsAndRegs vars
720 = saveVolatileVars vars `thenFC` \ var_saves ->
721 saveCurrentCostCentre `thenFC` \ (maybe_cc_slot, cc_save) ->
722 getEndOfBlockInfo `thenFC` \ eob_info ->
723 returnFC (mkAbstractCs [var_saves, cc_save],
728 saveVolatileVars :: StgLiveVars -- Vars which should be made safe
729 -> FCode AbstractC -- Assignments to to the saves
731 saveVolatileVars vars
732 = save_em (varSetElems vars)
734 save_em [] = returnFC AbsCNop
737 = getCAddrModeIfVolatile var `thenFC` \ v ->
739 Nothing -> save_em vars -- Non-volatile, so carry on
742 Just vol_amode -> -- Aha! It's volatile
743 save_var var vol_amode `thenFC` \ abs_c ->
744 save_em vars `thenFC` \ abs_cs ->
745 returnFC (abs_c `mkAbsCStmts` abs_cs)
747 save_var var vol_amode
748 = allocPrimStack (getPrimRepSize kind) `thenFC` \ slot ->
749 rebindToStack var slot `thenC`
750 getSpRelOffset slot `thenFC` \ sp_rel ->
751 returnFC (CAssign (CVal sp_rel kind) vol_amode)
753 kind = getAmodeRep vol_amode
756 ---------------------------------------------------------------------------
758 When we save the current cost centre (which is done for lexical
759 scoping), we allocate a free stack location, and return (a)~the
760 virtual offset of the location, to pass on to the alternatives, and
761 (b)~the assignment to do the save (just as for @saveVolatileVars@).
764 saveCurrentCostCentre ::
765 FCode (Maybe VirtualSpOffset, -- Where we decide to store it
766 AbstractC) -- Assignment to save it
768 saveCurrentCostCentre
769 = if not opt_SccProfilingOn then
770 returnFC (Nothing, AbsCNop)
772 allocPrimStack (getPrimRepSize CostCentreRep) `thenFC` \ slot ->
773 dataStackSlots [slot] `thenC`
774 getSpRelOffset slot `thenFC` \ sp_rel ->
776 CAssign (CVal sp_rel CostCentreRep) (CReg CurCostCentre))
778 restoreCurrentCostCentre :: Maybe VirtualSpOffset -> FCode AbstractC
779 restoreCurrentCostCentre Nothing = returnFC AbsCNop
780 restoreCurrentCostCentre (Just slot)
781 = getSpRelOffset slot `thenFC` \ sp_rel ->
782 freeStackSlots [slot] `thenC`
783 returnFC (CCallProfCCMacro SLIT("RESTORE_CCCS") [CVal sp_rel CostCentreRep])
784 -- we use the RESTORE_CCCS macro, rather than just
785 -- assigning into CurCostCentre, in case RESTORE_CCCS
786 -- has some sanity-checking in it.
789 %************************************************************************
791 \subsection[CgCase-return-vec]{Building a return vector}
793 %************************************************************************
795 Build a return vector, and return a suitable label addressing
799 mkReturnVector :: Unique
800 -> [(ConTag, AbstractC)] -- Branch codes
801 -> AbstractC -- Default case
802 -> SRT -- continuation's SRT
803 -> Liveness -- stack liveness
804 -> CtrlReturnConvention
807 mkReturnVector uniq tagged_alt_absCs deflt_absC srt liveness ret_conv
808 = getSRTLabel `thenFC` \srt_label ->
810 (return_vec_amode, vtbl_body) = case ret_conv of {
812 -- might be a polymorphic case...
813 UnvectoredReturn 0 ->
814 ASSERT(null tagged_alt_absCs)
815 (CLbl ret_label RetRep,
816 absC (CRetDirect uniq deflt_absC (srt_label, srt) liveness));
818 UnvectoredReturn n ->
819 -- find the tag explicitly rather than using tag_reg for now.
820 -- on architectures with lots of regs the tag will be loaded
821 -- into tag_reg by the code doing the returning.
823 tag = CMacroExpr WordRep GET_TAG [CVal (nodeRel 0) DataPtrRep]
825 (CLbl ret_label RetRep,
826 absC (CRetDirect uniq
827 (mkAlgAltsCSwitch tag tagged_alt_absCs deflt_absC)
831 VectoredReturn table_size ->
833 (vector_table, alts_absC) =
834 unzip (map mk_vector_entry [fIRST_TAG .. (table_size+fIRST_TAG-1)])
836 ret_vector = CRetVector vtbl_label
838 (srt_label, srt) liveness
840 (CLbl vtbl_label DataPtrRep,
841 -- alts come first, because we don't want to declare all the symbols
842 absC (mkAbstractCs (mkAbstractCs alts_absC : [deflt_absC,ret_vector]))
847 returnFC return_vec_amode
851 vtbl_label = mkVecTblLabel uniq
852 ret_label = mkReturnInfoLabel uniq
855 case nonemptyAbsC deflt_absC of
856 -- the simplifier might have eliminated a case
857 Nothing -> mkIntCLit 0 -- CLbl mkErrorStdEntryLabel CodePtrRep
858 Just absC@(CCodeBlock lbl _) -> CLbl lbl CodePtrRep
860 mk_vector_entry :: ConTag -> (CAddrMode, AbstractC)
862 = case [ absC | (t, absC) <- tagged_alt_absCs, t == tag ] of
863 [] -> (deflt_lbl, AbsCNop)
864 [absC@(CCodeBlock lbl _)] -> (CLbl lbl CodePtrRep,absC)
865 _ -> panic "mkReturnVector: too many"
868 %************************************************************************
870 \subsection[CgCase-utils]{Utilities for handling case expressions}
872 %************************************************************************
874 @possibleHeapCheck@ tests a flag passed in to decide whether to do a
875 heap check or not. These heap checks are always in a case
876 alternative, so we use altHeapCheck.
881 -> Bool -- True <=> algebraic case
882 -> [MagicId] -- live registers
883 -> [(VirtualSpOffset,Int)] -- stack slots to tag
884 -> Maybe Unique -- return address unique
885 -> Code -- continuation
888 possibleHeapCheck GCMayHappen is_alg regs tags lbl code
889 = altHeapCheck is_alg regs tags AbsCNop lbl code
890 possibleHeapCheck NoGC _ _ tags lbl code