2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 % $Id: CgCase.lhs,v 1.64 2003/07/02 13:18:24 simonpj Exp $
6 %********************************************************
8 \section[CgCase]{Converting @StgCase@ expressions}
10 %********************************************************
13 module CgCase ( cgCase, saveVolatileVarsAndRegs,
14 mkRetDirectTarget, restoreCurrentCostCentre
17 #include "HsVersions.h"
19 import {-# SOURCE #-} CgExpr ( cgExpr )
25 import AbsCUtils ( mkAbstractCs, mkAbsCStmts, mkAlgAltsCSwitch, getAmodeRep )
26 import CgBindery ( getVolatileRegs, getArgAmodes,
27 bindNewToReg, bindNewToTemp,
29 rebindToStack, getCAddrMode, getCAddrModeIfVolatile,
30 buildContLivenessMask, nukeDeadBindings,
32 import CgCon ( bindConArgs, bindUnboxedTupleComponents )
33 import CgHeapery ( altHeapCheck, unbxTupleHeapCheck )
34 import CgRetConv ( dataReturnConvPrim, ctrlReturnConvAlg,
35 CtrlReturnConvention(..)
37 import CgStackery ( allocPrimStack, allocStackTop,
38 deAllocStackTop, freeStackSlots, dataStackSlots
40 import CgTailCall ( performTailCall )
41 import CgUsages ( getSpRelOffset )
42 import CLabel ( mkVecTblLabel, mkClosureTblLabel,
43 mkDefaultLabel, mkAltLabel, mkReturnInfoLabel
45 import ClosureInfo ( mkLFArgument )
46 import CmdLineOpts ( opt_SccProfilingOn )
47 import Id ( Id, idName, isDeadBinder )
48 import DataCon ( dataConTag, fIRST_TAG, ConTag )
49 import VarSet ( varSetElems )
50 import CoreSyn ( AltCon(..) )
51 import PrimOp ( primOpOutOfLine, PrimOp(..) )
52 import PrimRep ( getPrimRepSize, retPrimRepSize, PrimRep(..)
54 import TyCon ( TyCon, isEnumerationTyCon, tyConPrimRep )
55 import Unique ( Unique, Uniquable(..), newTagUnique )
57 import List ( sortBy )
63 = GCMayHappen -- The scrutinee may involve GC, so everything must be
64 -- tidy before the code for the scrutinee.
66 | NoGC -- The scrutinee is a primitive value, or a call to a
67 -- primitive op which does no GC. Hence the case can
68 -- be done inline, without tidying up first.
71 It is quite interesting to decide whether to put a heap-check
72 at the start of each alternative. Of course we certainly have
73 to do so if the case forces an evaluation, or if there is a primitive
74 op which can trigger GC.
76 A more interesting situation is this:
83 default -> !C!; ...C...
86 where \tr{!x!} indicates a possible heap-check point. The heap checks
87 in the alternatives {\em can} be omitted, in which case the topmost
88 heapcheck will take their worst case into account.
90 In favour of omitting \tr{!B!}, \tr{!C!}:
92 - {\em May} save a heap overflow test,
93 if ...A... allocates anything. The other advantage
94 of this is that we can use relative addressing
95 from a single Hp to get at all the closures so allocated.
97 - No need to save volatile vars etc across the case
101 - May do more allocation than reqd. This sometimes bites us
102 badly. For example, nfib (ha!) allocates about 30\% more space if the
103 worst-casing is done, because many many calls to nfib are leaf calls
104 which don't need to allocate anything.
106 This never hurts us if there is only one alternative.
119 Special case #1: case of literal.
122 cgCase (StgLit lit) live_in_whole_case live_in_alts bndr srt
123 alt_type@(PrimAlt tycon) alts
124 = bindNewToTemp bndr `thenFC` \ tmp_amode ->
125 absC (CAssign tmp_amode (CLit lit)) `thenC`
126 cgPrimAlts NoGC tmp_amode alts alt_type
129 Special case #2: scrutinising a primitive-typed variable. No
130 evaluation required. We don't save volatile variables, nor do we do a
131 heap-check in the alternatives. Instead, the heap usage of the
132 alternatives is worst-cased and passed upstream. This can result in
133 allocating more heap than strictly necessary, but it will sometimes
134 eliminate a heap check altogether.
137 cgCase (StgApp v []) live_in_whole_case live_in_alts bndr srt
138 alt_type@(PrimAlt tycon) alts
140 = -- Careful! we can't just bind the default binder to the same thing
141 -- as the scrutinee, since it might be a stack location, and having
142 -- two bindings pointing at the same stack locn doesn't work (it
143 -- confuses nukeDeadBindings). Hence, use a new temp.
144 getCAddrMode v `thenFC` \ amode ->
145 bindNewToTemp bndr `thenFC` \ tmp_amode ->
146 absC (CAssign tmp_amode amode) `thenC`
147 cgPrimAlts NoGC tmp_amode alts alt_type
150 Special case #3: inline PrimOps.
153 cgCase (StgOpApp op@(StgPrimOp primop) args _)
154 live_in_whole_case live_in_alts bndr srt alt_type alts
155 | not (primOpOutOfLine primop)
156 = -- Get amodes for the arguments and results
157 getArgAmodes args `thenFC` \ arg_amodes ->
158 getVolatileRegs live_in_alts `thenFC` \ vol_regs ->
161 PrimAlt tycon -- PRIMITIVE ALTS
162 -> bindNewToTemp bndr `thenFC` \ tmp_amode ->
163 absC (COpStmt [tmp_amode] op arg_amodes vol_regs) `thenC`
164 -- Note: no liveness arg
165 cgPrimAlts NoGC tmp_amode alts alt_type
167 UbxTupAlt tycon -- UNBOXED TUPLE ALTS
168 -> -- No heap check, no yield, just get in there and do it.
169 -- NB: the case binder isn't bound to anything;
170 -- it has a unboxed tuple type
171 mapFCs bindNewToTemp res_ids `thenFC` \ res_tmps ->
172 absC (COpStmt res_tmps op arg_amodes vol_regs) `thenC`
175 [(_, res_ids, _, rhs)] = alts
177 AlgAlt tycon -- ENUMERATION TYPE RETURN
178 -> ASSERT( isEnumerationTyCon tycon )
179 do_enum_primop primop `thenFC` \ tag_amode ->
181 -- Bind the default binder if necessary
182 -- (avoiding it avoids the assignment)
183 -- The deadness info is set by StgVarInfo
184 (if (isDeadBinder bndr)
186 else bindNewToTemp bndr `thenFC` \ tmp_amode ->
187 absC (CAssign tmp_amode (tagToClosure tycon tag_amode))
191 cgAlgAlts NoGC (getUnique bndr)
192 Nothing{-cc_slot-} False{-no semi-tagging-}
193 (AlgAlt tycon) alts `thenFC` \ tagged_alts ->
196 absC (mkAlgAltsCSwitch tag_amode tagged_alts)
198 do_enum_primop :: PrimOp -> FCode CAddrMode -- Returns amode for result
199 do_enum_primop TagToEnumOp -- No code!
200 = returnFC (only arg_amodes)
202 do_enum_primop primop
203 = absC (COpStmt [tag_amode] op arg_amodes vol_regs) `thenC`
206 tag_amode = CTemp (newTagUnique (getUnique bndr) 'C') IntRep
207 -- Being a bit short of uniques for temporary variables here,
208 -- we use newTagUnique to generate a new unique from the case
209 -- binder. The case binder's unique will presumably have
210 -- the 'c' tag (generated by CoreToStg), so we just change
211 -- its tag to 'C' (for 'case') to ensure it doesn't clash with
213 -- We can't use the unique from the case binder, becaus e
214 -- this is used to hold the actual result closure
215 -- (via the call to bindNewToTemp)
217 other -> pprPanic "cgCase: case of primop has strange alt type" (ppr alt_type)
220 TODO: Case-of-case of primop can probably be done inline too (but
221 maybe better to translate it out beforehand). See
222 ghc/lib/misc/PackedString.lhs for examples where this crops up (with
225 Special case: scrutinising a non-primitive variable.
226 This can be done a little better than the general case, because
227 we can reuse/trim the stack slot holding the variable (if it is in one).
230 cgCase (StgApp fun args)
231 live_in_whole_case live_in_alts bndr srt alt_type alts
232 = getCAddrModeAndInfo fun `thenFC` \ (fun', fun_amode, lf_info) ->
233 getArgAmodes args `thenFC` \ arg_amodes ->
235 -- Nuking dead bindings *before* calculating the saves is the
236 -- value-add here. We might end up freeing up some slots currently
237 -- occupied by variables only required for the call.
238 -- NOTE: we need to look up the variables used in the call before
239 -- doing this, because some of them may not be in the environment
241 nukeDeadBindings live_in_alts `thenC`
242 saveVolatileVarsAndRegs live_in_alts
243 `thenFC` \ (save_assts, alts_eob_info, maybe_cc_slot) ->
245 forkEval alts_eob_info
246 ( allocStackTop retPrimRepSize
247 `thenFC` \_ -> nopC )
248 ( deAllocStackTop retPrimRepSize `thenFC` \_ ->
249 cgEvalAlts maybe_cc_slot bndr srt alt_type alts )
250 `thenFC` \ scrut_eob_info ->
252 setEndOfBlockInfo (maybeReserveSeqFrame alt_type scrut_eob_info) $
253 performTailCall fun' fun_amode lf_info arg_amodes save_assts
256 Note about return addresses: we *always* push a return address, even
257 if because of an optimisation we end up jumping direct to the return
258 code (not through the address itself). The alternatives always assume
259 that the return address is on the stack. The return address is
260 required in case the alternative performs a heap check, since it
261 encodes the liveness of the slots in the activation record.
263 On entry to the case alternative, we can re-use the slot containing
264 the return address immediately after the heap check. That's what the
265 deAllocStackTop call is doing above.
267 Finally, here is the general case.
270 cgCase expr live_in_whole_case live_in_alts bndr srt alt_type alts
271 = -- Figure out what volatile variables to save
272 nukeDeadBindings live_in_whole_case `thenC`
274 saveVolatileVarsAndRegs live_in_alts
275 `thenFC` \ (save_assts, alts_eob_info, maybe_cc_slot) ->
277 -- Save those variables right now!
278 absC save_assts `thenC`
280 -- generate code for the alts
281 forkEval alts_eob_info
282 (nukeDeadBindings live_in_alts `thenC`
283 allocStackTop retPrimRepSize -- space for retn address
286 (deAllocStackTop retPrimRepSize `thenFC` \_ ->
287 cgEvalAlts maybe_cc_slot bndr srt alt_type alts) `thenFC` \ scrut_eob_info ->
289 setEndOfBlockInfo (maybeReserveSeqFrame alt_type scrut_eob_info) $
293 There's a lot of machinery going on behind the scenes to manage the
294 stack pointer here. forkEval takes the virtual Sp and free list from
295 the first argument, and turns that into the *real* Sp for the second
296 argument. It also uses this virtual Sp as the args-Sp in the EOB info
297 returned, so that the scrutinee will trim the real Sp back to the
298 right place before doing whatever it does.
299 --SDM (who just spent an hour figuring this out, and didn't want to
302 Why don't we push the return address just before evaluating the
303 scrutinee? Because the slot reserved for the return address might
304 contain something useful, so we wait until performing a tail call or
305 return before pushing the return address (see
306 CgTailCall.pushReturnAddress).
308 This also means that the environment doesn't need to know about the
309 free stack slot for the return address (for generating bitmaps),
310 because we don't reserve it until just before the eval.
312 TODO!! Problem: however, we have to save the current cost centre
313 stack somewhere, because at the eval point the current CCS might be
314 different. So we pick a free stack slot and save CCCS in it. The
315 problem with this is that this slot isn't recorded as free/unboxed in
316 the environment, so a case expression in the scrutinee will have the
317 wrong bitmap attached. Fortunately we don't ever seem to see
318 case-of-case at the back end. One solution might be to shift the
319 saved CCS to the correct place in the activation record just before
323 (one consequence of the above is that activation records on the stack
324 don't follow the layout of closures when we're profiling. The CCS
325 could be anywhere within the record).
328 maybeReserveSeqFrame PolyAlt (EndOfBlockInfo args_sp (CaseAlts amode stuff _))
329 = EndOfBlockInfo (args_sp + retPrimRepSize) (CaseAlts amode stuff True)
330 maybeReserveSeqFrame other scrut_eob_info = scrut_eob_info
333 %************************************************************************
335 \subsection[CgCase-alts]{Alternatives}
337 %************************************************************************
339 @cgEvalAlts@ returns an addressing mode for a continuation for the
340 alternatives of a @case@, used in a context when there
341 is some evaluation to be done.
344 cgEvalAlts :: Maybe VirtualSpOffset -- Offset of cost-centre to be restored, if any
346 -> SRT -- SRT for the continuation
349 -> FCode Sequel -- Any addr modes inside are guaranteed
350 -- to be a label so that we can duplicate it
351 -- without risk of duplicating code
353 cgEvalAlts cc_slot bndr srt (UbxTupAlt _) [(con,args,_,rhs)]
354 = -- Unboxed tuple case
355 -- By now, the simplifier should have have turned it
356 -- into case e of (# a,b #) -> e
357 -- There shouldn't be a
358 -- case e of DEFAULT -> e
359 ASSERT2( case con of { DataAlt _ -> True; other -> False },
360 text "cgEvalAlts: dodgy case of unboxed tuple type" )
362 forkAbsC ( -- forkAbsC for the RHS, so that the envt is
363 -- not changed for the mkRetDirect call
364 restoreCurrentCostCentre cc_slot `thenC`
365 bindUnboxedTupleComponents args `thenFC` \ (live_regs, ptrs, nptrs, _) ->
366 -- Generate a heap check if necessary
367 unbxTupleHeapCheck live_regs ptrs nptrs AbsCNop $
368 -- And finally the code for the alternative
370 ) `thenFC` \ abs_c ->
371 mkRetDirectTarget bndr abs_c srt `thenFC` \ lbl ->
372 returnFC (CaseAlts lbl Nothing False)
374 cgEvalAlts cc_slot bndr srt alt_type@(PrimAlt tycon) alts
375 = forkAbsC ( -- forkAbsC for the RHS, so that the envt is
376 -- not changed for the mkRetDirect call
377 restoreCurrentCostCentre cc_slot `thenC`
378 bindNewToReg bndr reg (mkLFArgument bndr) `thenC`
379 cgPrimAlts GCMayHappen (CReg reg) alts alt_type
380 ) `thenFC` \ abs_c ->
381 mkRetDirectTarget bndr abs_c srt `thenFC` \ lbl ->
382 returnFC (CaseAlts lbl Nothing False)
384 reg = dataReturnConvPrim kind
385 kind = tyConPrimRep tycon
387 cgEvalAlts cc_slot bndr srt alt_type alts
388 = -- Algebraic and polymorphic case
389 -- Bind the default binder
390 bindNewToReg bndr node (mkLFArgument bndr) `thenC`
392 -- Generate sequel info for use downstream
393 -- At the moment, we only do it if the type is vector-returnable.
394 -- Reason: if not, then it costs extra to label the
395 -- alternatives, because we'd get return code like:
397 -- switch TagReg { 0 : JMP(alt_1); 1 : JMP(alt_2) ..etc }
399 -- which is worse than having the alt code in the switch statement
401 let ret_conv = case alt_type of
402 AlgAlt tc -> ctrlReturnConvAlg tc
403 PolyAlt -> UnvectoredReturn 0
405 use_labelled_alts = case ret_conv of
406 VectoredReturn _ -> True
409 semi_tagged_stuff = cgSemiTaggedAlts use_labelled_alts bndr alts
412 cgAlgAlts GCMayHappen (getUnique bndr)
413 cc_slot use_labelled_alts
414 alt_type alts `thenFC` \ tagged_alt_absCs ->
416 mkRetVecTarget bndr tagged_alt_absCs
417 srt ret_conv `thenFC` \ return_vec ->
419 returnFC (CaseAlts return_vec semi_tagged_stuff False)
423 HWL comment on {\em GrAnSim\/} (adding GRAN_YIELDs for context switch): If
424 we do an inlining of the case no separate functions for returning are
425 created, so we don't have to generate a GRAN_YIELD in that case. This info
426 must be propagated to cgAlgAltRhs (where the GRAN_YIELD macro might be
427 emitted). Hence, the new Bool arg to cgAlgAltRhs.
429 %************************************************************************
431 \subsection[CgCase-alg-alts]{Algebraic alternatives}
433 %************************************************************************
435 In @cgAlgAlts@, none of the binders in the alternatives are
436 assumed to be yet bound.
438 HWL comment on {\em GrAnSim\/} (adding GRAN_YIELDs for context switch): The
439 last arg of cgAlgAlts indicates if we want a context switch at the
440 beginning of each alternative. Normally we want that. The only exception
441 are inlined alternatives.
446 -> Maybe VirtualSpOffset
447 -> Bool -- True <=> branches must be labelled
448 -- (used for semi-tagging)
449 -> AltType -- ** AlgAlt or PolyAlt only **
450 -> [StgAlt] -- The alternatives
451 -> FCode [(AltCon, AbstractC)] -- The branches
453 cgAlgAlts gc_flag uniq restore_cc must_label_branches alt_type alts
454 = forkAlts [ cgAlgAlt gc_flag uniq restore_cc must_label_branches alt_type alt
458 -> Unique -> Maybe VirtualSpOffset -> Bool -- turgid state
459 -> AltType -- ** AlgAlt or PolyAlt only **
461 -> FCode (AltCon, AbstractC)
463 cgAlgAlt gc_flag uniq cc_slot must_label_branch
464 alt_type (con, args, use_mask, rhs)
465 = getAbsC (bind_con_args con args `thenFC` \ _ ->
466 restoreCurrentCostCentre cc_slot `thenC`
467 maybeAltHeapCheck gc_flag alt_type (cgExpr rhs)
468 ) `thenFC` \ abs_c ->
470 final_abs_c | must_label_branch = CCodeBlock lbl abs_c
473 returnFC (con, final_abs_c)
476 DataAlt dc -> mkAltLabel uniq (dataConTag dc)
477 DEFAULT -> mkDefaultLabel uniq
478 other -> pprPanic "cgAlgAlt" (ppr con)
480 bind_con_args DEFAULT args = nopC
481 bind_con_args (DataAlt dc) args = bindConArgs dc args
484 %************************************************************************
486 \subsection[CgCase-semi-tagged-alts]{The code to deal with sem-tagging}
488 %************************************************************************
490 Turgid-but-non-monadic code to conjure up the required info from
491 algebraic case alternatives for semi-tagging.
494 cgSemiTaggedAlts :: Bool -- True <=> use semitagging: each alt will be labelled
499 cgSemiTaggedAlts False binder alts
501 cgSemiTaggedAlts True binder alts
502 = Just ([st_alt con args | (DataAlt con, args, _, _) <- alts],
504 (DEFAULT, _, _, _) -> Just st_deflt
507 uniq = getUnique binder
510 (CCallProfCtrMacro FSLIT("RET_SEMI_BY_DEFAULT") [], -- ToDo: monadise?
511 mkDefaultLabel uniq))
513 st_alt con args -- Ha! Nothing to do; Node already points to the thing
515 (CCallProfCtrMacro FSLIT("RET_SEMI_IN_HEAP") -- ToDo: monadise?
516 [mkIntCLit (length args)], -- how big the thing in the heap is
520 con_tag = dataConTag con
521 join_label = mkAltLabel uniq con_tag
524 tagToClosure :: TyCon -> CAddrMode -> CAddrMode
525 -- Primops returning an enumeration type (notably Bool)
526 -- actually return an index into
527 -- the table of closures for the enumeration type
528 tagToClosure tycon tag_amode
529 = CVal (CIndex closure_tbl tag_amode PtrRep) PtrRep
531 closure_tbl = CLbl (mkClosureTblLabel tycon) PtrRep
534 %************************************************************************
536 \subsection[CgCase-prim-alts]{Primitive alternatives}
538 %************************************************************************
540 @cgPrimAlts@ generates suitable a @CSwitch@
541 for dealing with the alternatives of a primitive @case@, given an
542 addressing mode for the thing to scrutinise. It also keeps track of
543 the maximum stack depth encountered down any branch.
545 As usual, no binders in the alternatives are yet bound.
549 -> CAddrMode -- Scrutinee
550 -> [StgAlt] -- Alternatives
553 -- INVARIANT: the default binder is already bound
554 cgPrimAlts gc_flag scrutinee alts alt_type
555 = forkAlts (map (cgPrimAlt gc_flag alt_type) alts) `thenFC` \ tagged_absCs ->
557 ((DEFAULT, deflt_absC) : others) = tagged_absCs -- There is always a default
558 alt_absCs = [(lit,rhs) | (LitAlt lit, rhs) <- others]
560 absC (CSwitch scrutinee alt_absCs deflt_absC)
561 -- CSwitch does sensible things with one or zero alternatives
565 -> StgAlt -- The alternative
566 -> FCode (AltCon, AbstractC) -- Its compiled form
568 cgPrimAlt gc_flag alt_type (con, [], [], rhs)
569 = ASSERT( case con of { DEFAULT -> True; LitAlt _ -> True; other -> False } )
570 getAbsC (maybeAltHeapCheck gc_flag alt_type (cgExpr rhs)) `thenFC` \ abs_c ->
571 returnFC (con, abs_c)
575 %************************************************************************
577 \subsection[CgCase-tidy]{Code for tidying up prior to an eval}
579 %************************************************************************
584 -> AltType -- PolyAlt, PrimAlt, AlgAlt, but *not* UbxTupAlt
585 -> Code -- Continuation
587 maybeAltHeapCheck NoGC _ code = code
588 maybeAltHeapCheck GCMayHappen alt_type code
589 = -- HWL: maybe need yield here
590 -- yield [node] True -- XXX live regs wrong
591 altHeapCheck alt_type code
593 saveVolatileVarsAndRegs
594 :: StgLiveVars -- Vars which should be made safe
595 -> FCode (AbstractC, -- Assignments to do the saves
596 EndOfBlockInfo, -- sequel for the alts
597 Maybe VirtualSpOffset) -- Slot for current cost centre
599 saveVolatileVarsAndRegs vars
600 = saveVolatileVars vars `thenFC` \ var_saves ->
601 saveCurrentCostCentre `thenFC` \ (maybe_cc_slot, cc_save) ->
602 getEndOfBlockInfo `thenFC` \ eob_info ->
603 returnFC (mkAbstractCs [var_saves, cc_save],
608 saveVolatileVars :: StgLiveVars -- Vars which should be made safe
609 -> FCode AbstractC -- Assignments to to the saves
611 saveVolatileVars vars
612 = save_em (varSetElems vars)
614 save_em [] = returnFC AbsCNop
617 = getCAddrModeIfVolatile var `thenFC` \ v ->
619 Nothing -> save_em vars -- Non-volatile, so carry on
622 Just vol_amode -> -- Aha! It's volatile
623 save_var var vol_amode `thenFC` \ abs_c ->
624 save_em vars `thenFC` \ abs_cs ->
625 returnFC (abs_c `mkAbsCStmts` abs_cs)
627 save_var var vol_amode
628 = allocPrimStack (getPrimRepSize kind) `thenFC` \ slot ->
629 rebindToStack var slot `thenC`
630 getSpRelOffset slot `thenFC` \ sp_rel ->
631 returnFC (CAssign (CVal sp_rel kind) vol_amode)
633 kind = getAmodeRep vol_amode
636 ---------------------------------------------------------------------------
638 When we save the current cost centre (which is done for lexical
639 scoping), we allocate a free stack location, and return (a)~the
640 virtual offset of the location, to pass on to the alternatives, and
641 (b)~the assignment to do the save (just as for @saveVolatileVars@).
644 saveCurrentCostCentre ::
645 FCode (Maybe VirtualSpOffset, -- Where we decide to store it
646 AbstractC) -- Assignment to save it
648 saveCurrentCostCentre
649 = if not opt_SccProfilingOn then
650 returnFC (Nothing, AbsCNop)
652 allocPrimStack (getPrimRepSize CostCentreRep) `thenFC` \ slot ->
653 dataStackSlots [slot] `thenC`
654 getSpRelOffset slot `thenFC` \ sp_rel ->
656 CAssign (CVal sp_rel CostCentreRep) (CReg CurCostCentre))
658 restoreCurrentCostCentre :: Maybe VirtualSpOffset -> Code
659 restoreCurrentCostCentre Nothing = nopC
660 restoreCurrentCostCentre (Just slot)
661 = getSpRelOffset slot `thenFC` \ sp_rel ->
662 freeStackSlots [slot] `thenC`
663 absC (CCallProfCCMacro FSLIT("RESTORE_CCCS") [CVal sp_rel CostCentreRep])
664 -- we use the RESTORE_CCCS macro, rather than just
665 -- assigning into CurCostCentre, in case RESTORE_CCCS
666 -- has some sanity-checking in it.
669 %************************************************************************
671 \subsection[CgCase-return-vec]{Building a return vector}
673 %************************************************************************
675 Build a return vector, and return a suitable label addressing
679 mkRetDirectTarget :: Id -- Used for labelling only
680 -> AbstractC -- Return code
681 -> SRT -- Live CAFs in return code
682 -> FCode CAddrMode -- Emit the labelled return block,
683 -- and return its label
684 mkRetDirectTarget bndr abs_c srt
685 = buildContLivenessMask bndr `thenFC` \ liveness ->
686 getSRTInfo name srt `thenFC` \ srt_info ->
687 absC (CRetDirect uniq abs_c srt_info liveness) `thenC`
691 uniq = getUnique name
692 lbl = CLbl (mkReturnInfoLabel uniq) RetRep
696 mkRetVecTarget :: Id -- Just for its unique
697 -> [(AltCon, AbstractC)] -- Branch codes
698 -> SRT -- Continuation's SRT
699 -> CtrlReturnConvention
702 mkRetVecTarget bndr tagged_alt_absCs srt (UnvectoredReturn 0)
703 = ASSERT( null other_alts )
704 mkRetDirectTarget bndr deflt_absC srt
706 ((DEFAULT, deflt_absC) : other_alts) = tagged_alt_absCs
708 mkRetVecTarget bndr tagged_alt_absCs srt (UnvectoredReturn n)
709 = mkRetDirectTarget bndr switch_absC srt
711 -- Find the tag explicitly rather than using tag_reg for now.
712 -- on architectures with lots of regs the tag will be loaded
713 -- into tag_reg by the code doing the returning.
714 tag = CMacroExpr WordRep GET_TAG [CVal (nodeRel 0) DataPtrRep]
715 switch_absC = mkAlgAltsCSwitch tag tagged_alt_absCs
718 mkRetVecTarget bndr tagged_alt_absCs srt (VectoredReturn table_size)
719 = buildContLivenessMask bndr `thenFC` \ liveness ->
720 getSRTInfo name srt `thenFC` \ srt_info ->
722 ret_vector = CRetVector vtbl_lbl vector_table srt_info liveness
724 absC (mkAbstractCs alts_absCs `mkAbsCStmts` ret_vector) `thenC`
725 -- Alts come first, because we don't want to declare all the symbols
727 return (CLbl vtbl_lbl DataPtrRep)
729 tags = [fIRST_TAG .. (table_size+fIRST_TAG-1)]
730 vector_table = map mk_vector_entry tags
731 alts_absCs = map snd (sortBy cmp tagged_alt_absCs)
732 -- The sort is unnecessary; just there for now
733 -- to make the new order the same as the old
734 (DEFAULT,_) `cmp` (DEFAULT,_) = EQ
735 (DEFAULT,_) `cmp` _ = GT
736 (DataAlt d1,_) `cmp` (DataAlt d2,_) = dataConTag d1 `compare` dataConTag d2
737 (DataAlt d1,_) `cmp` (DEFAULT, _) = LT
741 uniq = getUnique name
742 vtbl_lbl = mkVecTblLabel uniq
744 deflt_lbl :: CAddrMode
745 deflt_lbl = case tagged_alt_absCs of
746 (DEFAULT, abs_c) : _ -> get_block_label abs_c
748 -- 'other' case: the simplifier might have eliminated a case
749 -- so we may have e.g. case xs of
751 -- In that situation the default should never be taken,
752 -- so we just use '0' (=> seg fault if used)
754 mk_vector_entry :: ConTag -> CAddrMode
756 = case [ absC | (DataAlt d, absC) <- tagged_alt_absCs, dataConTag d == tag ] of
757 -- The comprehension neatly, and correctly, ignores the DEFAULT
759 [abs_c] -> get_block_label abs_c
760 _ -> panic "mkReturnVector: too many"
762 get_block_label (CCodeBlock lbl _) = CLbl lbl CodePtrRep