2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 % $Id: CgCase.lhs,v 1.29 1999/05/18 15:03:46 simonpj Exp $
6 %********************************************************
8 \section[CgCase]{Converting @StgCase@ expressions}
10 %********************************************************
13 module CgCase ( cgCase, saveVolatileVarsAndRegs,
14 restoreCurrentCostCentre, freeCostCentreSlot
17 #include "HsVersions.h"
19 import {-# SOURCE #-} CgExpr ( cgExpr )
25 import AbsCUtils ( mkAbstractCs, mkAbsCStmts, mkAlgAltsCSwitch,
26 getAmodeRep, nonemptyAbsC
28 import CgUpdate ( reserveSeqFrame )
29 import CgBindery ( getVolatileRegs, getArgAmodes, getArgAmode,
30 bindNewToReg, bindNewToTemp,
32 rebindToStack, getCAddrMode,
33 getCAddrModeAndInfo, getCAddrModeIfVolatile,
34 buildContLivenessMask, nukeDeadBindings,
36 import CgCon ( bindConArgs, bindUnboxedTupleComponents )
37 import CgHeapery ( altHeapCheck, yield )
38 import CgRetConv ( dataReturnConvPrim, ctrlReturnConvAlg,
39 CtrlReturnConvention(..)
41 import CgStackery ( allocPrimStack, allocStackTop,
42 deAllocStackTop, freeStackSlots
44 import CgTailCall ( tailCallFun )
45 import CgUsages ( getSpRelOffset, getRealSp )
46 import CLabel ( CLabel, mkVecTblLabel, mkReturnPtLabel,
47 mkDefaultLabel, mkAltLabel, mkReturnInfoLabel,
48 mkErrorStdEntryLabel, mkClosureTblLabel
50 import ClosureInfo ( mkLFArgument )
51 import CmdLineOpts ( opt_SccProfilingOn, opt_GranMacros )
52 import CostCentre ( CostCentre )
53 import CoreSyn ( isDeadBinder )
54 import Id ( Id, idPrimRep )
55 import DataCon ( DataCon, dataConTag, fIRST_TAG, ConTag,
56 isUnboxedTupleCon, dataConType )
57 import VarSet ( varSetElems )
58 import Const ( Con(..), Literal )
59 import PrimOp ( primOpOutOfLine, PrimOp(..) )
60 import PrimRep ( getPrimRepSize, retPrimRepSize, PrimRep(..)
62 import TyCon ( TyCon, isEnumerationTyCon, isUnboxedTupleTyCon,
63 isNewTyCon, isAlgTyCon, isFunTyCon, isPrimTyCon,
64 tyConDataCons, tyConFamilySize )
65 import Type ( Type, typePrimRep, splitAlgTyConApp,
66 splitTyConApp_maybe, splitRepTyConApp_maybe )
67 import Unique ( Unique, Uniquable(..), mkBuiltinUnique )
68 import Maybes ( maybeToBool )
75 = GCMayHappen -- The scrutinee may involve GC, so everything must be
76 -- tidy before the code for the scrutinee.
78 | NoGC -- The scrutinee is a primitive value, or a call to a
79 -- primitive op which does no GC. Hence the case can
80 -- be done inline, without tidying up first.
83 It is quite interesting to decide whether to put a heap-check
84 at the start of each alternative. Of course we certainly have
85 to do so if the case forces an evaluation, or if there is a primitive
86 op which can trigger GC.
88 A more interesting situation is this:
95 default -> !C!; ...C...
98 where \tr{!x!} indicates a possible heap-check point. The heap checks
99 in the alternatives {\em can} be omitted, in which case the topmost
100 heapcheck will take their worst case into account.
102 In favour of omitting \tr{!B!}, \tr{!C!}:
104 - {\em May} save a heap overflow test,
105 if ...A... allocates anything. The other advantage
106 of this is that we can use relative addressing
107 from a single Hp to get at all the closures so allocated.
109 - No need to save volatile vars etc across the case
113 - May do more allocation than reqd. This sometimes bites us
114 badly. For example, nfib (ha!) allocates about 30\% more space if the
115 worst-casing is done, because many many calls to nfib are leaf calls
116 which don't need to allocate anything.
118 This never hurts us if there is only one alternative.
130 Special case #1: PrimOps returning enumeration types.
132 For enumeration types, we invent a temporary (builtin-unique 1) to
133 hold the tag, and cross our fingers that this doesn't clash with
134 anything else. Builtin-unique 0 is used for a similar reason when
135 compiling enumerated-type primops in CgExpr.lhs. We can't use the
136 unique from the case binder, because this is used to hold the actual
137 closure (when the case binder is live, that is).
139 There is an extra special case for
144 which generates no code for the primop, unless x is used in the
145 alternatives (in which case we lookup the tag in the relevant closure
146 table to get the closure).
149 cgCase (StgCon (PrimOp op) args res_ty)
150 live_in_whole_case live_in_alts bndr srt (StgAlgAlts ty alts deflt)
151 | isEnumerationTyCon tycon
152 = getArgAmodes args `thenFC` \ arg_amodes ->
154 let tag_amode = case op of
155 TagToEnumOp -> only arg_amodes
156 _ -> CTemp (mkBuiltinUnique 1) IntRep
158 closure = CTableEntry (CLbl (mkClosureTblLabel tycon) PtrRep) tag_amode PtrRep
162 TagToEnumOp -> nopC; -- no code!
164 _ -> -- Perform the operation
165 getVolatileRegs live_in_alts `thenFC` \ vol_regs ->
167 absC (COpStmt [tag_amode] op
168 arg_amodes -- note: no liveness arg
172 -- bind the default binder if necessary
173 (if (isDeadBinder bndr)
175 else bindNewToTemp bndr `thenFC` \ bndr_amode ->
176 absC (CAssign bndr_amode closure))
180 cgAlgAlts NoGC uniq Nothing{-cc_slot-} False{-no semi-tagging-}
181 False{-not poly case-} alts deflt
182 False{-don't emit yield-} `thenFC` \ (tagged_alts, deflt_c) ->
185 absC (mkAlgAltsCSwitch tag_amode tagged_alts deflt_c)
188 (Just (tycon,_)) = splitTyConApp_maybe res_ty
189 uniq = getUnique bndr
192 Special case #2: inline PrimOps.
195 cgCase (StgCon (PrimOp op) args res_ty)
196 live_in_whole_case live_in_alts bndr srt alts
197 | not (primOpOutOfLine op)
199 -- Get amodes for the arguments and results
200 getArgAmodes args `thenFC` \ arg_amodes ->
202 result_amodes = getPrimAppResultAmodes (getUnique bndr) alts
204 -- Perform the operation
205 getVolatileRegs live_in_alts `thenFC` \ vol_regs ->
207 absC (COpStmt result_amodes op
208 arg_amodes -- note: no liveness arg
211 -- Scrutinise the result
212 cgInlineAlts bndr alts
215 TODO: Case-of-case of primop can probably be done inline too (but
216 maybe better to translate it out beforehand). See
217 ghc/lib/misc/PackedString.lhs for examples where this crops up (with
220 Another special case: scrutinising a primitive-typed variable. No
221 evaluation required. We don't save volatile variables, nor do we do a
222 heap-check in the alternatives. Instead, the heap usage of the
223 alternatives is worst-cased and passed upstream. This can result in
224 allocating more heap than strictly necessary, but it will sometimes
225 eliminate a heap check altogether.
228 cgCase (StgApp v []) live_in_whole_case live_in_alts bndr srt
229 (StgPrimAlts ty alts deflt)
232 getCAddrMode v `thenFC` \amode ->
235 Careful! we can't just bind the default binder to the same thing
236 as the scrutinee, since it might be a stack location, and having
237 two bindings pointing at the same stack locn doesn't work (it
238 confuses nukeDeadBindings). Hence, use a new temp.
240 bindNewToTemp bndr `thenFC` \deflt_amode ->
241 absC (CAssign deflt_amode amode) `thenC`
243 cgPrimAlts NoGC amode alts deflt []
246 Special case: scrutinising a non-primitive variable.
247 This can be done a little better than the general case, because
248 we can reuse/trim the stack slot holding the variable (if it is in one).
251 cgCase (StgApp fun args)
252 live_in_whole_case live_in_alts bndr srt alts@(StgAlgAlts ty _ _)
254 getCAddrModeAndInfo fun `thenFC` \ (fun_amode, lf_info) ->
255 getArgAmodes args `thenFC` \ arg_amodes ->
257 -- Squish the environment
258 nukeDeadBindings live_in_alts `thenC`
259 saveVolatileVarsAndRegs live_in_alts
260 `thenFC` \ (save_assts, alts_eob_info, maybe_cc_slot) ->
262 allocStackTop retPrimRepSize `thenFC` \_ ->
264 forkEval alts_eob_info nopC (
265 deAllocStackTop retPrimRepSize `thenFC` \_ ->
266 cgEvalAlts maybe_cc_slot bndr srt alts)
267 `thenFC` \ scrut_eob_info ->
269 let real_scrut_eob_info =
271 then reserveSeqFrame scrut_eob_info
275 setEndOfBlockInfo real_scrut_eob_info (
276 tailCallFun fun fun_amode lf_info arg_amodes save_assts
280 not_con_ty = case (getScrutineeTyCon ty) of
285 Note about return addresses: we *always* push a return address, even
286 if because of an optimisation we end up jumping direct to the return
287 code (not through the address itself). The alternatives always assume
288 that the return address is on the stack. The return address is
289 required in case the alternative performs a heap check, since it
290 encodes the liveness of the slots in the activation record.
292 On entry to the case alternative, we can re-use the slot containing
293 the return address immediately after the heap check. That's what the
294 deAllocStackTop call is doing above.
296 Finally, here is the general case.
299 cgCase expr live_in_whole_case live_in_alts bndr srt alts
300 = -- Figure out what volatile variables to save
301 nukeDeadBindings live_in_whole_case `thenC`
303 saveVolatileVarsAndRegs live_in_alts
304 `thenFC` \ (save_assts, alts_eob_info, maybe_cc_slot) ->
306 -- Save those variables right now!
307 absC save_assts `thenC`
309 -- generate code for the alts
310 forkEval alts_eob_info
312 nukeDeadBindings live_in_alts `thenC`
313 allocStackTop retPrimRepSize -- space for retn address
316 (deAllocStackTop retPrimRepSize `thenFC` \_ ->
317 cgEvalAlts maybe_cc_slot bndr srt alts) `thenFC` \ scrut_eob_info ->
319 let real_scrut_eob_info =
321 then reserveSeqFrame scrut_eob_info
325 setEndOfBlockInfo real_scrut_eob_info (cgExpr expr)
328 not_con_ty = case (getScrutineeTyCon (alts_ty alts)) of
333 There's a lot of machinery going on behind the scenes to manage the
334 stack pointer here. forkEval takes the virtual Sp and free list from
335 the first argument, and turns that into the *real* Sp for the second
336 argument. It also uses this virtual Sp as the args-Sp in the EOB info
337 returned, so that the scrutinee will trim the real Sp back to the
338 right place before doing whatever it does.
339 --SDM (who just spent an hour figuring this out, and didn't want to
342 Why don't we push the return address just before evaluating the
343 scrutinee? Because the slot reserved for the return address might
344 contain something useful, so we wait until performing a tail call or
345 return before pushing the return address (see
346 CgTailCall.pushReturnAddress).
348 This also means that the environment doesn't need to know about the
349 free stack slot for the return address (for generating bitmaps),
350 because we don't reserve it until just before the eval.
352 TODO!! Problem: however, we have to save the current cost centre
353 stack somewhere, because at the eval point the current CCS might be
354 different. So we pick a free stack slot and save CCCS in it. The
355 problem with this is that this slot isn't recorded as free/unboxed in
356 the environment, so a case expression in the scrutinee will have the
357 wrong bitmap attached. Fortunately we don't ever seem to see
358 case-of-case at the back end. One solution might be to shift the
359 saved CCS to the correct place in the activation record just before
363 (one consequence of the above is that activation records on the stack
364 don't follow the layout of closures when we're profiling. The CCS
365 could be anywhere within the record).
368 alts_ty (StgAlgAlts ty _ _) = ty
369 alts_ty (StgPrimAlts ty _ _) = ty
372 %************************************************************************
374 \subsection[CgCase-primops]{Primitive applications}
376 %************************************************************************
378 Get result amodes for a primitive operation, in the case wher GC can't happen.
379 The amodes are returned in canonical order, ready for the prim-op!
381 Alg case: temporaries named as in the alternatives,
382 plus (CTemp u) for the tag (if needed)
385 This is all disgusting, because these amodes must be consistent with those
386 invented by CgAlgAlts.
389 getPrimAppResultAmodes
394 getPrimAppResultAmodes uniq (StgAlgAlts ty alts some_default)
396 | isUnboxedTupleTyCon tycon =
398 [(con, args, use_mask, rhs)] ->
399 [ CTemp (getUnique arg) (idPrimRep arg) | arg <- args ]
400 _ -> panic "getPrimAppResultAmodes: case of unboxed tuple has multiple branches"
402 | otherwise = panic ("getPrimAppResultAmodes: case of primop has strange type: " ++ showSDoc (ppr ty))
404 where (tycon, _, _) = splitAlgTyConApp ty
406 -- The situation is simpler for primitive results, because there is only
409 getPrimAppResultAmodes uniq (StgPrimAlts ty _ _)
410 = [CTemp uniq (typePrimRep ty)]
414 %************************************************************************
416 \subsection[CgCase-alts]{Alternatives}
418 %************************************************************************
420 @cgEvalAlts@ returns an addressing mode for a continuation for the
421 alternatives of a @case@, used in a context when there
422 is some evaluation to be done.
425 cgEvalAlts :: Maybe VirtualSpOffset -- Offset of cost-centre to be restored, if any
427 -> SRT -- SRT for the continuation
429 -> FCode Sequel -- Any addr modes inside are guaranteed
430 -- to be a label so that we can duplicate it
431 -- without risk of duplicating code
433 cgEvalAlts cc_slot bndr srt alts
435 let uniq = getUnique bndr in
437 -- get the stack liveness for the info table (after the CC slot has
438 -- been freed - this is important).
439 freeCostCentreSlot cc_slot `thenC`
440 buildContLivenessMask uniq `thenFC` \ liveness_mask ->
444 -- algebraic alts ...
445 (StgAlgAlts ty alts deflt) ->
447 -- bind the default binder (it covers all the alternatives)
448 bindNewToReg bndr node mkLFArgument `thenC`
450 -- Generate sequel info for use downstream
451 -- At the moment, we only do it if the type is vector-returnable.
452 -- Reason: if not, then it costs extra to label the
453 -- alternatives, because we'd get return code like:
455 -- switch TagReg { 0 : JMP(alt_1); 1 : JMP(alt_2) ..etc }
457 -- which is worse than having the alt code in the switch statement
459 let tycon_info = getScrutineeTyCon ty
460 is_alg = maybeToBool tycon_info
461 Just spec_tycon = tycon_info
464 -- deal with the unboxed tuple case
465 if is_alg && isUnboxedTupleTyCon spec_tycon then
467 [alt] -> let lbl = mkReturnInfoLabel uniq in
468 cgUnboxedTupleAlt uniq cc_slot True alt
470 getSRTLabel `thenFC` \srt_label ->
471 absC (CRetDirect uniq abs_c (srt_label, srt)
472 liveness_mask) `thenC`
473 returnFC (CaseAlts (CLbl lbl RetRep) Nothing)
474 _ -> panic "cgEvalAlts: dodgy case of unboxed tuple type"
476 -- normal algebraic (or polymorphic) case alternatives
478 ret_conv | is_alg = ctrlReturnConvAlg spec_tycon
479 | otherwise = UnvectoredReturn 0
481 use_labelled_alts = case ret_conv of
482 VectoredReturn _ -> True
486 = if use_labelled_alts then
487 cgSemiTaggedAlts bndr alts deflt -- Just <something>
489 Nothing -- no semi-tagging info
492 cgAlgAlts GCMayHappen uniq cc_slot use_labelled_alts (not is_alg)
493 alts deflt True `thenFC` \ (tagged_alt_absCs, deflt_absC) ->
495 mkReturnVector uniq tagged_alt_absCs deflt_absC srt liveness_mask
496 ret_conv `thenFC` \ return_vec ->
498 returnFC (CaseAlts return_vec semi_tagged_stuff)
501 (StgPrimAlts ty alts deflt) ->
503 -- Generate the switch
504 getAbsC (cgPrimEvalAlts bndr ty alts deflt) `thenFC` \ abs_c ->
506 -- Generate the labelled block, starting with restore-cost-centre
507 getSRTLabel `thenFC` \srt_label ->
508 restoreCurrentCostCentre cc_slot `thenFC` \ cc_restore ->
509 absC (CRetDirect uniq (cc_restore `mkAbsCStmts` abs_c)
510 (srt_label,srt) liveness_mask) `thenC`
512 -- Return an amode for the block
513 returnFC (CaseAlts (CLbl (mkReturnInfoLabel uniq) RetRep) Nothing)
523 HWL comment on {\em GrAnSim\/} (adding GRAN_YIELDs for context switch): If
524 we do an inlining of the case no separate functions for returning are
525 created, so we don't have to generate a GRAN_YIELD in that case. This info
526 must be propagated to cgAlgAltRhs (where the GRAN_YIELD macro might be
527 emitted). Hence, the new Bool arg to cgAlgAltRhs.
529 First case: primitive op returns an unboxed tuple.
532 cgInlineAlts bndr (StgAlgAlts ty [alt@(con,args,use_mask,rhs)] StgNoDefault)
533 | isUnboxedTupleCon con
534 = -- no heap check, no yield, just get in there and do it.
535 mapFCs bindNewToTemp args `thenFC` \ _ ->
539 = panic "cgInlineAlts: single alternative, not an unboxed tuple"
542 Third (real) case: primitive result type.
545 cgInlineAlts bndr (StgPrimAlts ty alts deflt)
546 = cgPrimInlineAlts bndr ty alts deflt
549 %************************************************************************
551 \subsection[CgCase-alg-alts]{Algebraic alternatives}
553 %************************************************************************
555 In @cgAlgAlts@, none of the binders in the alternatives are
556 assumed to be yet bound.
558 HWL comment on {\em GrAnSim\/} (adding GRAN_YIELDs for context switch): The
559 last arg of cgAlgAlts indicates if we want a context switch at the
560 beginning of each alternative. Normally we want that. The only exception
561 are inlined alternatives.
566 -> Maybe VirtualSpOffset
567 -> Bool -- True <=> branches must be labelled
568 -> Bool -- True <=> polymorphic case
569 -> [(DataCon, [Id], [Bool], StgExpr)] -- The alternatives
570 -> StgCaseDefault -- The default
571 -> Bool -- Context switch at alts?
572 -> FCode ([(ConTag, AbstractC)], -- The branches
573 AbstractC -- The default case
576 cgAlgAlts gc_flag uniq restore_cc must_label_branches is_fun alts deflt
577 emit_yield{-should a yield macro be emitted?-}
579 = forkAlts (map (cgAlgAlt gc_flag uniq restore_cc must_label_branches emit_yield) alts)
580 (cgAlgDefault gc_flag is_fun uniq restore_cc must_label_branches deflt emit_yield)
584 cgAlgDefault :: GCFlag
585 -> Bool -- could be a function-typed result?
586 -> Unique -> Maybe VirtualSpOffset -> Bool -- turgid state...
587 -> StgCaseDefault -- input
589 -> FCode AbstractC -- output
591 cgAlgDefault gc_flag is_fun uniq cc_slot must_label_branch StgNoDefault _
594 cgAlgDefault gc_flag is_fun uniq cc_slot must_label_branch
596 emit_yield{-should a yield macro be emitted?-}
598 = -- We have arranged that Node points to the thing
599 restoreCurrentCostCentre cc_slot `thenFC` \restore_cc ->
600 getAbsC (absC restore_cc `thenC`
601 (if opt_GranMacros && emit_yield
602 then yield [node] False
603 else absC AbsCNop) `thenC`
604 possibleHeapCheck gc_flag is_fun [node] [] Nothing (cgExpr rhs)
605 -- Node is live, but doesn't need to point at the thing itself;
606 -- it's ok for Node to point to an indirection or FETCH_ME
607 -- Hence no need to re-enter Node.
608 ) `thenFC` \ abs_c ->
611 final_abs_c | must_label_branch = CCodeBlock lbl abs_c
616 lbl = mkDefaultLabel uniq
618 -- HWL comment on GrAnSim: GRAN_YIELDs needed; emitted in cgAlgAltRhs
621 -> Unique -> Maybe VirtualSpOffset -> Bool -- turgid state
622 -> Bool -- Context switch at alts?
623 -> (DataCon, [Id], [Bool], StgExpr)
624 -> FCode (ConTag, AbstractC)
626 cgAlgAlt gc_flag uniq cc_slot must_label_branch
627 emit_yield{-should a yield macro be emitted?-}
628 (con, args, use_mask, rhs)
630 restoreCurrentCostCentre cc_slot `thenFC` \restore_cc ->
631 getAbsC (absC restore_cc `thenC`
632 (if opt_GranMacros && emit_yield
633 then yield [node] True -- XXX live regs wrong
634 else absC AbsCNop) `thenC`
636 NoGC -> mapFCs bindNewToTemp args `thenFC` \_ -> nopC
637 GCMayHappen -> bindConArgs con args
639 possibleHeapCheck gc_flag False [node] [] Nothing (
641 ) `thenFC` \ abs_c ->
643 final_abs_c | must_label_branch = CCodeBlock lbl abs_c
646 returnFC (tag, final_abs_c)
649 lbl = mkAltLabel uniq tag
652 :: Unique -- unique for label of the alternative
653 -> Maybe VirtualSpOffset -- Restore cost centre
654 -> Bool -- ctxt switch
655 -> (DataCon, [Id], [Bool], StgExpr) -- alternative
658 cgUnboxedTupleAlt lbl cc_slot emit_yield (con,args,use_mask,rhs)
660 bindUnboxedTupleComponents args
661 `thenFC` \ (live_regs,tags,stack_res) ->
663 restoreCurrentCostCentre cc_slot `thenFC` \restore_cc ->
664 absC restore_cc `thenC`
666 (if opt_GranMacros && emit_yield
667 then yield live_regs True -- XXX live regs wrong?
668 else absC AbsCNop) `thenC`
670 -- ToDo: could maybe use Nothing here if stack_res is False
671 -- since the heap-check can just return to the top of the
676 -- free up stack slots containing tags,
677 freeStackSlots (map fst tags) `thenC`
679 -- generate a heap check if necessary
680 possibleHeapCheck GCMayHappen False live_regs tags ret_addr (
682 -- and finally the code for the alternative
687 %************************************************************************
689 \subsection[CgCase-semi-tagged-alts]{The code to deal with sem-tagging}
691 %************************************************************************
693 Turgid-but-non-monadic code to conjure up the required info from
694 algebraic case alternatives for semi-tagging.
697 cgSemiTaggedAlts :: Id
698 -> [(DataCon, [Id], [Bool], StgExpr)]
699 -> GenStgCaseDefault Id Id
702 cgSemiTaggedAlts binder alts deflt
703 = Just (map st_alt alts, st_deflt deflt)
705 uniq = getUnique binder
707 st_deflt StgNoDefault = Nothing
709 st_deflt (StgBindDefault _)
711 (CCallProfCtrMacro SLIT("RET_SEMI_BY_DEFAULT") [], -- ToDo: monadise?
715 st_alt (con, args, use_mask, _)
716 = -- Ha! Nothing to do; Node already points to the thing
718 (CCallProfCtrMacro SLIT("RET_SEMI_IN_HEAP") -- ToDo: monadise?
719 [mkIntCLit (length args)], -- how big the thing in the heap is
723 con_tag = dataConTag con
724 join_label = mkAltLabel uniq con_tag
727 %************************************************************************
729 \subsection[CgCase-prim-alts]{Primitive alternatives}
731 %************************************************************************
733 @cgPrimEvalAlts@ and @cgPrimInlineAlts@ generate suitable @CSwitch@es
734 for dealing with the alternatives of a primitive @case@, given an
735 addressing mode for the thing to scrutinise. It also keeps track of
736 the maximum stack depth encountered down any branch.
738 As usual, no binders in the alternatives are yet bound.
741 cgPrimInlineAlts bndr ty alts deflt
742 = cgPrimAltsWithDefault bndr NoGC (CTemp uniq kind) alts deflt []
744 uniq = getUnique bndr
745 kind = typePrimRep ty
747 cgPrimEvalAlts bndr ty alts deflt
748 = cgPrimAltsWithDefault bndr GCMayHappen (CReg reg) alts deflt [reg]
750 reg = dataReturnConvPrim kind
751 kind = typePrimRep ty
753 cgPrimAltsWithDefault bndr gc_flag scrutinee alts deflt regs
754 = -- first bind the default if necessary
755 bindNewPrimToAmode bndr scrutinee `thenC`
756 cgPrimAlts gc_flag scrutinee alts deflt regs
758 cgPrimAlts gc_flag scrutinee alts deflt regs
759 = forkAlts (map (cgPrimAlt gc_flag regs) alts)
760 (cgPrimDefault gc_flag regs deflt)
761 `thenFC` \ (alt_absCs, deflt_absC) ->
763 absC (CSwitch scrutinee alt_absCs deflt_absC)
764 -- CSwitch does sensible things with one or zero alternatives
768 -> [MagicId] -- live registers
769 -> (Literal, StgExpr) -- The alternative
770 -> FCode (Literal, AbstractC) -- Its compiled form
772 cgPrimAlt gc_flag regs (lit, rhs)
773 = getAbsC rhs_code `thenFC` \ absC ->
776 rhs_code = possibleHeapCheck gc_flag False regs [] Nothing (cgExpr rhs)
778 cgPrimDefault :: GCFlag
779 -> [MagicId] -- live registers
783 cgPrimDefault gc_flag regs StgNoDefault
784 = panic "cgPrimDefault: No default in prim case"
786 cgPrimDefault gc_flag regs (StgBindDefault rhs)
787 = getAbsC (possibleHeapCheck gc_flag False regs [] Nothing (cgExpr rhs))
791 %************************************************************************
793 \subsection[CgCase-tidy]{Code for tidying up prior to an eval}
795 %************************************************************************
798 saveVolatileVarsAndRegs
799 :: StgLiveVars -- Vars which should be made safe
800 -> FCode (AbstractC, -- Assignments to do the saves
801 EndOfBlockInfo, -- sequel for the alts
802 Maybe VirtualSpOffset) -- Slot for current cost centre
805 saveVolatileVarsAndRegs vars
806 = saveVolatileVars vars `thenFC` \ var_saves ->
807 saveCurrentCostCentre `thenFC` \ (maybe_cc_slot, cc_save) ->
808 getEndOfBlockInfo `thenFC` \ eob_info ->
809 returnFC (mkAbstractCs [var_saves, cc_save],
814 saveVolatileVars :: StgLiveVars -- Vars which should be made safe
815 -> FCode AbstractC -- Assignments to to the saves
817 saveVolatileVars vars
818 = save_em (varSetElems vars)
820 save_em [] = returnFC AbsCNop
823 = getCAddrModeIfVolatile var `thenFC` \ v ->
825 Nothing -> save_em vars -- Non-volatile, so carry on
828 Just vol_amode -> -- Aha! It's volatile
829 save_var var vol_amode `thenFC` \ abs_c ->
830 save_em vars `thenFC` \ abs_cs ->
831 returnFC (abs_c `mkAbsCStmts` abs_cs)
833 save_var var vol_amode
834 = allocPrimStack (getPrimRepSize kind) `thenFC` \ slot ->
835 rebindToStack var slot `thenC`
836 getSpRelOffset slot `thenFC` \ sp_rel ->
837 returnFC (CAssign (CVal sp_rel kind) vol_amode)
839 kind = getAmodeRep vol_amode
842 ---------------------------------------------------------------------------
844 When we save the current cost centre (which is done for lexical
845 scoping), we allocate a free stack location, and return (a)~the
846 virtual offset of the location, to pass on to the alternatives, and
847 (b)~the assignment to do the save (just as for @saveVolatileVars@).
850 saveCurrentCostCentre ::
851 FCode (Maybe VirtualSpOffset, -- Where we decide to store it
852 AbstractC) -- Assignment to save it
854 saveCurrentCostCentre
855 = if not opt_SccProfilingOn then
856 returnFC (Nothing, AbsCNop)
858 allocPrimStack (getPrimRepSize CostCentreRep) `thenFC` \ slot ->
859 getSpRelOffset slot `thenFC` \ sp_rel ->
861 CAssign (CVal sp_rel CostCentreRep) (CReg CurCostCentre))
863 freeCostCentreSlot :: Maybe VirtualSpOffset -> Code
864 freeCostCentreSlot Nothing = nopC
865 freeCostCentreSlot (Just slot) = freeStackSlots [slot]
867 restoreCurrentCostCentre :: Maybe VirtualSpOffset -> FCode AbstractC
868 restoreCurrentCostCentre Nothing = returnFC AbsCNop
869 restoreCurrentCostCentre (Just slot)
870 = getSpRelOffset slot `thenFC` \ sp_rel ->
871 returnFC (CCallProfCCMacro SLIT("RESTORE_CCCS") [CVal sp_rel CostCentreRep])
872 -- we use the RESTORE_CCCS macro, rather than just
873 -- assigning into CurCostCentre, in case RESTORE_CCC
874 -- has some sanity-checking in it.
877 %************************************************************************
879 \subsection[CgCase-return-vec]{Building a return vector}
881 %************************************************************************
883 Build a return vector, and return a suitable label addressing
887 mkReturnVector :: Unique
888 -> [(ConTag, AbstractC)] -- Branch codes
889 -> AbstractC -- Default case
890 -> SRT -- continuation's SRT
891 -> Liveness -- stack liveness
892 -> CtrlReturnConvention
895 mkReturnVector uniq tagged_alt_absCs deflt_absC srt liveness ret_conv
896 = getSRTLabel `thenFC` \srt_label ->
898 srt_info = (srt_label, srt)
900 (return_vec_amode, vtbl_body) = case ret_conv of {
902 -- might be a polymorphic case...
903 UnvectoredReturn 0 ->
904 ASSERT(null tagged_alt_absCs)
905 (CLbl ret_label RetRep,
906 absC (CRetDirect uniq deflt_absC (srt_label, srt) liveness));
908 UnvectoredReturn n ->
909 -- find the tag explicitly rather than using tag_reg for now.
910 -- on architectures with lots of regs the tag will be loaded
911 -- into tag_reg by the code doing the returning.
913 tag = CMacroExpr WordRep GET_TAG [CVal (nodeRel 0) DataPtrRep]
915 (CLbl ret_label RetRep,
916 absC (CRetDirect uniq
917 (mkAlgAltsCSwitch tag tagged_alt_absCs deflt_absC)
921 VectoredReturn table_size ->
923 (vector_table, alts_absC) =
924 unzip (map mk_vector_entry [fIRST_TAG .. (table_size+fIRST_TAG-1)])
926 ret_vector = CRetVector vtbl_label
928 (srt_label, srt) liveness
930 (CLbl vtbl_label DataPtrRep,
931 -- alts come first, because we don't want to declare all the symbols
932 absC (mkAbstractCs (mkAbstractCs alts_absC : [deflt_absC,ret_vector]))
937 returnFC return_vec_amode
941 vtbl_label = mkVecTblLabel uniq
942 ret_label = mkReturnInfoLabel uniq
945 case nonemptyAbsC deflt_absC of
946 -- the simplifier might have eliminated a case
947 Nothing -> CLbl mkErrorStdEntryLabel CodePtrRep
948 Just absC@(CCodeBlock lbl _) -> CLbl lbl CodePtrRep
950 mk_vector_entry :: ConTag -> (CAddrMode, AbstractC)
952 = case [ absC | (t, absC) <- tagged_alt_absCs, t == tag ] of
953 [] -> (deflt_lbl, AbsCNop)
954 [absC@(CCodeBlock lbl _)] -> (CLbl lbl CodePtrRep,absC)
955 _ -> panic "mkReturnVector: too many"
958 %************************************************************************
960 \subsection[CgCase-utils]{Utilities for handling case expressions}
962 %************************************************************************
964 @possibleHeapCheck@ tests a flag passed in to decide whether to do a
965 heap check or not. These heap checks are always in a case
966 alternative, so we use altHeapCheck.
971 -> Bool -- True <=> algebraic case
972 -> [MagicId] -- live registers
973 -> [(VirtualSpOffset,Int)] -- stack slots to tag
974 -> Maybe Unique -- return address unique
975 -> Code -- continuation
978 possibleHeapCheck GCMayHappen is_alg regs tags lbl code
979 = altHeapCheck is_alg regs tags AbsCNop lbl code
980 possibleHeapCheck NoGC _ _ tags lbl code
985 getScrutineeTyCon :: Type -> Maybe TyCon
986 getScrutineeTyCon ty =
987 case splitRepTyConApp_maybe ty of
990 if isFunTyCon tc then Nothing else -- not interested in funs
991 if isPrimTyCon tc then Just tc else -- return primitive tycons
992 -- otherwise (algebraic tycons) check the no. of constructors