2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 % $Id: CgCase.lhs,v 1.61 2002/12/11 15:36:25 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 CgBindery ( getVolatileRegs, getArgAmodes,
28 bindNewToReg, bindNewToTemp,
29 bindNewPrimToAmode, getCAddrModeAndInfo,
30 rebindToStack, getCAddrMode, getCAddrModeIfVolatile,
31 buildContLivenessMask, nukeDeadBindings,
33 import CgCon ( bindConArgs, bindUnboxedTupleComponents )
34 import CgHeapery ( altHeapCheck, unbxTupleHeapCheck )
35 import CgRetConv ( dataReturnConvPrim, ctrlReturnConvAlg,
36 CtrlReturnConvention(..)
38 import CgStackery ( allocPrimStack, allocStackTop,
39 deAllocStackTop, freeStackSlots, dataStackSlots
41 import CgTailCall ( performTailCall )
42 import CgUsages ( getSpRelOffset )
43 import CLabel ( mkVecTblLabel, mkClosureTblLabel,
44 mkDefaultLabel, mkAltLabel, mkReturnInfoLabel
46 import ClosureInfo ( mkLFArgument )
47 import CmdLineOpts ( opt_SccProfilingOn )
48 import Id ( Id, idPrimRep, isDeadBinder )
49 import DataCon ( DataCon, dataConTag, fIRST_TAG, ConTag )
50 import VarSet ( varSetElems )
51 import Literal ( Literal )
52 import PrimOp ( primOpOutOfLine, PrimOp(..) )
53 import PrimRep ( getPrimRepSize, retPrimRepSize, PrimRep(..)
55 import TyCon ( isEnumerationTyCon, isUnboxedTupleTyCon, tyConPrimRep )
56 import Name ( getName )
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 False{-not polymorphic-} (getUnique bndr)
181 Nothing{-cc_slot-} False{-no semi-tagging-}
182 alts deflt 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 -- Nuking dead bindings *before* calculating the saves is the
272 -- value-add here. We might end up freeing up some slots currently
273 -- occupied by variables only required for the call.
274 -- NOTE: we need to look up the variables used in the call before
275 -- doing this, because some of them may not be in the environment
277 nukeDeadBindings live_in_alts `thenC`
278 saveVolatileVarsAndRegs live_in_alts
279 `thenFC` \ (save_assts, alts_eob_info, maybe_cc_slot) ->
281 forkEval alts_eob_info
282 ( allocStackTop retPrimRepSize
283 `thenFC` \_ -> nopC )
284 ( deAllocStackTop retPrimRepSize `thenFC` \_ ->
285 cgEvalAlts maybe_cc_slot bndr srt alts )
286 `thenFC` \ scrut_eob_info ->
288 setEndOfBlockInfo (maybeReserveSeqFrame alts scrut_eob_info) $
289 performTailCall fun' fun_amode lf_info arg_amodes save_assts
292 Note about return addresses: we *always* push a return address, even
293 if because of an optimisation we end up jumping direct to the return
294 code (not through the address itself). The alternatives always assume
295 that the return address is on the stack. The return address is
296 required in case the alternative performs a heap check, since it
297 encodes the liveness of the slots in the activation record.
299 On entry to the case alternative, we can re-use the slot containing
300 the return address immediately after the heap check. That's what the
301 deAllocStackTop call is doing above.
303 Finally, here is the general case.
306 cgCase expr live_in_whole_case live_in_alts bndr srt alts
307 = -- Figure out what volatile variables to save
308 nukeDeadBindings live_in_whole_case `thenC`
310 saveVolatileVarsAndRegs live_in_alts
311 `thenFC` \ (save_assts, alts_eob_info, maybe_cc_slot) ->
313 -- Save those variables right now!
314 absC save_assts `thenC`
316 -- generate code for the alts
317 forkEval alts_eob_info
318 (nukeDeadBindings live_in_alts `thenC`
319 allocStackTop retPrimRepSize -- space for retn address
322 (deAllocStackTop retPrimRepSize `thenFC` \_ ->
323 cgEvalAlts maybe_cc_slot bndr srt alts) `thenFC` \ scrut_eob_info ->
325 setEndOfBlockInfo (maybeReserveSeqFrame alts scrut_eob_info) $
329 There's a lot of machinery going on behind the scenes to manage the
330 stack pointer here. forkEval takes the virtual Sp and free list from
331 the first argument, and turns that into the *real* Sp for the second
332 argument. It also uses this virtual Sp as the args-Sp in the EOB info
333 returned, so that the scrutinee will trim the real Sp back to the
334 right place before doing whatever it does.
335 --SDM (who just spent an hour figuring this out, and didn't want to
338 Why don't we push the return address just before evaluating the
339 scrutinee? Because the slot reserved for the return address might
340 contain something useful, so we wait until performing a tail call or
341 return before pushing the return address (see
342 CgTailCall.pushReturnAddress).
344 This also means that the environment doesn't need to know about the
345 free stack slot for the return address (for generating bitmaps),
346 because we don't reserve it until just before the eval.
348 TODO!! Problem: however, we have to save the current cost centre
349 stack somewhere, because at the eval point the current CCS might be
350 different. So we pick a free stack slot and save CCCS in it. The
351 problem with this is that this slot isn't recorded as free/unboxed in
352 the environment, so a case expression in the scrutinee will have the
353 wrong bitmap attached. Fortunately we don't ever seem to see
354 case-of-case at the back end. One solution might be to shift the
355 saved CCS to the correct place in the activation record just before
359 (one consequence of the above is that activation records on the stack
360 don't follow the layout of closures when we're profiling. The CCS
361 could be anywhere within the record).
364 maybeReserveSeqFrame (StgAlgAlts Nothing _ _)
365 (EndOfBlockInfo args_sp (CaseAlts amode stuff _))
366 = EndOfBlockInfo (args_sp + retPrimRepSize) (CaseAlts amode stuff True)
368 maybeReserveSeqFrame other scrut_eob_info = scrut_eob_info
371 %************************************************************************
373 \subsection[CgCase-alts]{Alternatives}
375 %************************************************************************
377 @cgEvalAlts@ returns an addressing mode for a continuation for the
378 alternatives of a @case@, used in a context when there
379 is some evaluation to be done.
382 cgEvalAlts :: Maybe VirtualSpOffset -- Offset of cost-centre to be restored, if any
384 -> SRT -- SRT for the continuation
386 -> FCode Sequel -- Any addr modes inside are guaranteed
387 -- to be a label so that we can duplicate it
388 -- without risk of duplicating code
390 cgEvalAlts cc_slot bndr srt alts
392 let uniq = getUnique bndr in
394 buildContLivenessMask (getName bndr) `thenFC` \ liveness ->
398 -- algebraic alts ...
399 StgAlgAlts maybe_tycon alts deflt ->
401 -- bind the default binder (it covers all the alternatives)
402 bindNewToReg bndr node (mkLFArgument bndr) `thenC`
404 -- Generate sequel info for use downstream
405 -- At the moment, we only do it if the type is vector-returnable.
406 -- Reason: if not, then it costs extra to label the
407 -- alternatives, because we'd get return code like:
409 -- switch TagReg { 0 : JMP(alt_1); 1 : JMP(alt_2) ..etc }
411 -- which is worse than having the alt code in the switch statement
413 let is_alg = maybeToBool maybe_tycon
414 Just spec_tycon = maybe_tycon
417 -- Deal with the unboxed tuple case
418 if is_alg && isUnboxedTupleTyCon spec_tycon then
419 -- By now, the simplifier should have have turned it
420 -- into case e of (# a,b #) -> e
421 -- There shouldn't be a
422 -- case e of DEFAULT -> e
423 ASSERT2( case (alts, deflt) of { ([_],StgNoDefault) -> True; other -> False },
424 text "cgEvalAlts: dodgy case of unboxed tuple type" )
427 lbl = mkReturnInfoLabel uniq
429 cgUnboxedTupleAlt uniq cc_slot True alt `thenFC` \ abs_c ->
430 getSRTInfo srt `thenFC` \ srt_info ->
431 absC (CRetDirect uniq abs_c srt_info liveness) `thenC`
432 returnFC (CaseAlts (CLbl lbl RetRep) Nothing False)
434 -- normal algebraic (or polymorphic) case alternatives
436 ret_conv | is_alg = ctrlReturnConvAlg spec_tycon
437 | otherwise = UnvectoredReturn 0
439 use_labelled_alts = case ret_conv of
440 VectoredReturn _ -> True
444 = if use_labelled_alts then
445 cgSemiTaggedAlts bndr alts deflt -- Just <something>
447 Nothing -- no semi-tagging info
450 cgAlgAlts GCMayHappen (not is_alg) uniq cc_slot use_labelled_alts
451 alts deflt True `thenFC` \ (tagged_alt_absCs, deflt_absC) ->
453 mkReturnVector uniq tagged_alt_absCs deflt_absC srt liveness
454 ret_conv `thenFC` \ return_vec ->
456 returnFC (CaseAlts return_vec semi_tagged_stuff False)
459 StgPrimAlts tycon alts deflt ->
461 -- Restore the cost centre
462 restoreCurrentCostCentre cc_slot `thenFC` \ cc_restore ->
464 -- Generate the switch
465 getAbsC (cgPrimEvalAlts bndr tycon alts deflt) `thenFC` \ abs_c ->
467 -- Generate the labelled block, starting with restore-cost-centre
468 getSRTInfo srt `thenFC` \srt_info ->
469 absC (CRetDirect uniq (cc_restore `mkAbsCStmts` abs_c)
470 srt_info liveness) `thenC`
472 -- Return an amode for the block
473 returnFC (CaseAlts (CLbl (mkReturnInfoLabel uniq) RetRep) Nothing False)
477 HWL comment on {\em GrAnSim\/} (adding GRAN_YIELDs for context switch): If
478 we do an inlining of the case no separate functions for returning are
479 created, so we don't have to generate a GRAN_YIELD in that case. This info
480 must be propagated to cgAlgAltRhs (where the GRAN_YIELD macro might be
481 emitted). Hence, the new Bool arg to cgAlgAltRhs.
483 %************************************************************************
485 \subsection[CgCase-alg-alts]{Algebraic alternatives}
487 %************************************************************************
489 In @cgAlgAlts@, none of the binders in the alternatives are
490 assumed to be yet bound.
492 HWL comment on {\em GrAnSim\/} (adding GRAN_YIELDs for context switch): The
493 last arg of cgAlgAlts indicates if we want a context switch at the
494 beginning of each alternative. Normally we want that. The only exception
495 are inlined alternatives.
499 -> Bool -- polymorphic case
501 -> Maybe VirtualSpOffset
502 -> Bool -- True <=> branches must be labelled
503 -> [(DataCon, [Id], [Bool], StgExpr)] -- The alternatives
504 -> StgCaseDefault -- The default
505 -> Bool -- Context switch at alts?
506 -> FCode ([(ConTag, AbstractC)], -- The branches
507 AbstractC -- The default case
510 cgAlgAlts gc_flag is_poly uniq restore_cc must_label_branches alts deflt
511 emit_yield{-should a yield macro be emitted?-}
513 = forkAlts (map (cgAlgAlt gc_flag uniq restore_cc must_label_branches emit_yield) alts)
514 (cgAlgDefault gc_flag is_poly uniq restore_cc must_label_branches deflt emit_yield)
518 cgAlgDefault :: GCFlag
519 -> Bool -- polymorphic case
520 -> Unique -> Maybe VirtualSpOffset -> Bool -- turgid state...
521 -> StgCaseDefault -- input
523 -> FCode AbstractC -- output
525 cgAlgDefault gc_flag is_poly uniq cc_slot must_label_branch StgNoDefault _
528 cgAlgDefault gc_flag is_poly uniq cc_slot must_label_branch
530 emit_yield{-should a yield macro be emitted?-}
532 = -- We have arranged that Node points to the thing
533 restoreCurrentCostCentre cc_slot `thenFC` \restore_cc ->
534 getAbsC (absC restore_cc `thenC`
535 -- HWL: maybe need yield here
537 -- then yield [node] True
538 -- else absC AbsCNop) `thenC`
539 algAltHeapCheck gc_flag is_poly [node] (cgExpr rhs)
540 -- Node is live, but doesn't need to point at the thing itself;
541 -- it's ok for Node to point to an indirection or FETCH_ME
542 -- Hence no need to re-enter Node.
543 ) `thenFC` \ abs_c ->
546 final_abs_c | must_label_branch = CCodeBlock lbl abs_c
551 lbl = mkDefaultLabel uniq
553 -- HWL comment on GrAnSim: GRAN_YIELDs needed; emitted in cgAlgAltRhs
556 -> Unique -> Maybe VirtualSpOffset -> Bool -- turgid state
557 -> Bool -- Context switch at alts?
558 -> (DataCon, [Id], [Bool], StgExpr)
559 -> FCode (ConTag, AbstractC)
561 cgAlgAlt gc_flag uniq cc_slot must_label_branch
562 emit_yield{-should a yield macro be emitted?-}
563 (con, args, use_mask, rhs)
565 restoreCurrentCostCentre cc_slot `thenFC` \restore_cc ->
566 getAbsC (absC restore_cc `thenC`
567 -- HWL: maybe need yield here
569 -- then yield [node] True -- XXX live regs wrong
570 -- else absC AbsCNop) `thenC`
572 NoGC -> mapFCs bindNewToTemp args `thenFC` \_ -> nopC
573 GCMayHappen -> bindConArgs con args
575 algAltHeapCheck gc_flag False{-not poly-} [node] (
577 ) `thenFC` \ abs_c ->
579 final_abs_c | must_label_branch = CCodeBlock lbl abs_c
582 returnFC (tag, final_abs_c)
585 lbl = mkAltLabel uniq tag
588 :: Unique -- unique for label of the alternative
589 -> Maybe VirtualSpOffset -- Restore cost centre
590 -> Bool -- ctxt switch
591 -> (DataCon, [Id], [Bool], StgExpr) -- alternative
594 cgUnboxedTupleAlt lbl cc_slot emit_yield (con,args,use_mask,rhs)
596 bindUnboxedTupleComponents args
597 `thenFC` \ (live_regs, ptrs, nptrs, stack_res) ->
599 restoreCurrentCostCentre cc_slot `thenFC` \restore_cc ->
600 absC restore_cc `thenC`
602 -- HWL: maybe need yield here
604 -- then yield live_regs True -- XXX live regs wrong?
605 -- else absC AbsCNop) `thenC`
607 -- generate a heap check if necessary
608 possibleUnbxTupleHeapCheck GCMayHappen live_regs ptrs nptrs (
610 -- and finally the code for the alternative
615 %************************************************************************
617 \subsection[CgCase-semi-tagged-alts]{The code to deal with sem-tagging}
619 %************************************************************************
621 Turgid-but-non-monadic code to conjure up the required info from
622 algebraic case alternatives for semi-tagging.
625 cgSemiTaggedAlts :: Id
626 -> [(DataCon, [Id], [Bool], StgExpr)]
627 -> GenStgCaseDefault Id Id
630 cgSemiTaggedAlts binder alts deflt
631 = Just (map st_alt alts, st_deflt deflt)
633 uniq = getUnique binder
635 st_deflt StgNoDefault = Nothing
637 st_deflt (StgBindDefault _)
639 (CCallProfCtrMacro FSLIT("RET_SEMI_BY_DEFAULT") [], -- ToDo: monadise?
643 st_alt (con, args, use_mask, _)
644 = -- Ha! Nothing to do; Node already points to the thing
646 (CCallProfCtrMacro FSLIT("RET_SEMI_IN_HEAP") -- ToDo: monadise?
647 [mkIntCLit (length args)], -- how big the thing in the heap is
651 con_tag = dataConTag con
652 join_label = mkAltLabel uniq con_tag
655 %************************************************************************
657 \subsection[CgCase-prim-alts]{Primitive alternatives}
659 %************************************************************************
661 @cgPrimEvalAlts@ and @cgPrimInlineAlts@ generate suitable @CSwitch@es
662 for dealing with the alternatives of a primitive @case@, given an
663 addressing mode for the thing to scrutinise. It also keeps track of
664 the maximum stack depth encountered down any branch.
666 As usual, no binders in the alternatives are yet bound.
669 cgPrimInlineAlts bndr tycon alts deflt
670 = cgPrimAltsWithDefault bndr NoGC (CTemp uniq kind) alts deflt []
672 uniq = getUnique bndr
673 kind = tyConPrimRep tycon
675 cgPrimEvalAlts bndr tycon alts deflt
676 = cgPrimAltsWithDefault bndr GCMayHappen (CReg reg) alts deflt [reg]
678 reg = dataReturnConvPrim kind
679 kind = tyConPrimRep tycon
681 cgPrimAltsWithDefault bndr gc_flag scrutinee alts deflt regs
682 = -- first bind the default if necessary
683 bindNewPrimToAmode bndr scrutinee `thenC`
684 cgPrimAlts gc_flag scrutinee alts deflt regs
686 cgPrimAlts gc_flag scrutinee alts deflt regs
687 = forkAlts (map (cgPrimAlt gc_flag regs) alts)
688 (cgPrimDefault gc_flag regs deflt)
689 `thenFC` \ (alt_absCs, deflt_absC) ->
691 absC (CSwitch scrutinee alt_absCs deflt_absC)
692 -- CSwitch does sensible things with one or zero alternatives
696 -> [MagicId] -- live registers
697 -> (Literal, StgExpr) -- The alternative
698 -> FCode (Literal, AbstractC) -- Its compiled form
700 cgPrimAlt gc_flag regs (lit, rhs)
701 = getAbsC rhs_code `thenFC` \ absC ->
704 rhs_code = primAltHeapCheck gc_flag regs (cgExpr rhs)
706 cgPrimDefault :: GCFlag
707 -> [MagicId] -- live registers
711 cgPrimDefault gc_flag regs StgNoDefault
712 = panic "cgPrimDefault: No default in prim case"
714 cgPrimDefault gc_flag regs (StgBindDefault rhs)
715 = getAbsC (primAltHeapCheck gc_flag regs (cgExpr rhs))
719 %************************************************************************
721 \subsection[CgCase-tidy]{Code for tidying up prior to an eval}
723 %************************************************************************
726 saveVolatileVarsAndRegs
727 :: StgLiveVars -- Vars which should be made safe
728 -> FCode (AbstractC, -- Assignments to do the saves
729 EndOfBlockInfo, -- sequel for the alts
730 Maybe VirtualSpOffset) -- Slot for current cost centre
733 saveVolatileVarsAndRegs vars
734 = saveVolatileVars vars `thenFC` \ var_saves ->
735 saveCurrentCostCentre `thenFC` \ (maybe_cc_slot, cc_save) ->
736 getEndOfBlockInfo `thenFC` \ eob_info ->
737 returnFC (mkAbstractCs [var_saves, cc_save],
742 saveVolatileVars :: StgLiveVars -- Vars which should be made safe
743 -> FCode AbstractC -- Assignments to to the saves
745 saveVolatileVars vars
746 = save_em (varSetElems vars)
748 save_em [] = returnFC AbsCNop
751 = getCAddrModeIfVolatile var `thenFC` \ v ->
753 Nothing -> save_em vars -- Non-volatile, so carry on
756 Just vol_amode -> -- Aha! It's volatile
757 save_var var vol_amode `thenFC` \ abs_c ->
758 save_em vars `thenFC` \ abs_cs ->
759 returnFC (abs_c `mkAbsCStmts` abs_cs)
761 save_var var vol_amode
762 = allocPrimStack (getPrimRepSize kind) `thenFC` \ slot ->
763 rebindToStack var slot `thenC`
764 getSpRelOffset slot `thenFC` \ sp_rel ->
765 returnFC (CAssign (CVal sp_rel kind) vol_amode)
767 kind = getAmodeRep vol_amode
770 ---------------------------------------------------------------------------
772 When we save the current cost centre (which is done for lexical
773 scoping), we allocate a free stack location, and return (a)~the
774 virtual offset of the location, to pass on to the alternatives, and
775 (b)~the assignment to do the save (just as for @saveVolatileVars@).
778 saveCurrentCostCentre ::
779 FCode (Maybe VirtualSpOffset, -- Where we decide to store it
780 AbstractC) -- Assignment to save it
782 saveCurrentCostCentre
783 = if not opt_SccProfilingOn then
784 returnFC (Nothing, AbsCNop)
786 allocPrimStack (getPrimRepSize CostCentreRep) `thenFC` \ slot ->
787 dataStackSlots [slot] `thenC`
788 getSpRelOffset slot `thenFC` \ sp_rel ->
790 CAssign (CVal sp_rel CostCentreRep) (CReg CurCostCentre))
792 restoreCurrentCostCentre :: Maybe VirtualSpOffset -> FCode AbstractC
793 restoreCurrentCostCentre Nothing = returnFC AbsCNop
794 restoreCurrentCostCentre (Just slot)
795 = getSpRelOffset slot `thenFC` \ sp_rel ->
796 freeStackSlots [slot] `thenC`
797 returnFC (CCallProfCCMacro FSLIT("RESTORE_CCCS") [CVal sp_rel CostCentreRep])
798 -- we use the RESTORE_CCCS macro, rather than just
799 -- assigning into CurCostCentre, in case RESTORE_CCCS
800 -- has some sanity-checking in it.
803 %************************************************************************
805 \subsection[CgCase-return-vec]{Building a return vector}
807 %************************************************************************
809 Build a return vector, and return a suitable label addressing
813 mkReturnVector :: Unique
814 -> [(ConTag, AbstractC)] -- Branch codes
815 -> AbstractC -- Default case
816 -> SRT -- continuation's SRT
817 -> Liveness -- stack liveness
818 -> CtrlReturnConvention
821 mkReturnVector uniq tagged_alt_absCs deflt_absC srt liveness ret_conv
822 = getSRTInfo srt `thenFC` \ srt_info ->
824 (return_vec_amode, vtbl_body) = case ret_conv of {
826 -- might be a polymorphic case...
827 UnvectoredReturn 0 ->
828 ASSERT(null tagged_alt_absCs)
829 (CLbl ret_label RetRep,
830 absC (CRetDirect uniq deflt_absC srt_info liveness));
832 UnvectoredReturn n ->
833 -- find the tag explicitly rather than using tag_reg for now.
834 -- on architectures with lots of regs the tag will be loaded
835 -- into tag_reg by the code doing the returning.
837 tag = CMacroExpr WordRep GET_TAG [CVal (nodeRel 0) DataPtrRep]
839 (CLbl ret_label RetRep,
840 absC (CRetDirect uniq
841 (mkAlgAltsCSwitch tag tagged_alt_absCs deflt_absC)
844 VectoredReturn table_size ->
846 (vector_table, alts_absC) =
847 unzip (map mk_vector_entry [fIRST_TAG .. (table_size+fIRST_TAG-1)])
849 ret_vector = CRetVector vtbl_label vector_table srt_info liveness
851 (CLbl vtbl_label DataPtrRep,
852 -- alts come first, because we don't want to declare all the symbols
853 absC (mkAbstractCs (mkAbstractCs alts_absC : [deflt_absC,ret_vector]))
858 returnFC return_vec_amode
862 vtbl_label = mkVecTblLabel uniq
863 ret_label = mkReturnInfoLabel uniq
866 case nonemptyAbsC deflt_absC of
867 -- the simplifier might have eliminated a case
868 Nothing -> mkIntCLit 0 -- CLbl mkErrorStdEntryLabel CodePtrRep
869 Just absC@(CCodeBlock lbl _) -> CLbl lbl CodePtrRep
871 mk_vector_entry :: ConTag -> (CAddrMode, AbstractC)
873 = case [ absC | (t, absC) <- tagged_alt_absCs, t == tag ] of
874 [] -> (deflt_lbl, AbsCNop)
875 [absC@(CCodeBlock lbl _)] -> (CLbl lbl CodePtrRep,absC)
876 _ -> panic "mkReturnVector: too many"
879 %************************************************************************
881 \subsection[CgCase-utils]{Utilities for handling case expressions}
883 %************************************************************************
885 'possibleHeapCheck' tests a flag passed in to decide whether to do a
886 heap check or not. These heap checks are always in a case
887 alternative, so we use altHeapCheck.
892 -> Bool -- polymorphic case
893 -> [MagicId] -- live registers
894 -> Code -- continuation
897 algAltHeapCheck GCMayHappen is_poly regs code = altHeapCheck is_poly regs code
898 algAltHeapCheck NoGC _ _ code = code
902 -> [MagicId] -- live registers
903 -> Code -- continuation
906 primAltHeapCheck GCMayHappen regs code = altHeapCheck True regs code
907 primAltHeapCheck NoGC _ code = code
909 possibleUnbxTupleHeapCheck
911 -> [MagicId] -- live registers
912 -> Int -- no. of stack slots containing ptrs
913 -> Int -- no. of stack slots containing nonptrs
914 -> Code -- continuation
917 possibleUnbxTupleHeapCheck GCMayHappen regs ptrs nptrs code
918 = unbxTupleHeapCheck regs ptrs nptrs AbsCNop code
919 possibleUnbxTupleHeapCheck NoGC _ _ _ code