2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 % $Id: CgCase.lhs,v 1.33 1999/06/24 13:04:16 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, getArgAmode,
29 bindNewToReg, bindNewToTemp,
31 rebindToStack, getCAddrMode,
32 getCAddrModeAndInfo, getCAddrModeIfVolatile,
33 buildContLivenessMask, nukeDeadBindings,
35 import CgCon ( bindConArgs, bindUnboxedTupleComponents )
36 import CgHeapery ( altHeapCheck, yield )
37 import CgRetConv ( dataReturnConvPrim, ctrlReturnConvAlg,
38 CtrlReturnConvention(..)
40 import CgStackery ( allocPrimStack, allocStackTop,
41 deAllocStackTop, freeStackSlots, dataStackSlots
43 import CgTailCall ( tailCallFun )
44 import CgUsages ( getSpRelOffset, getRealSp )
45 import CLabel ( CLabel, mkVecTblLabel, mkReturnPtLabel,
46 mkDefaultLabel, mkAltLabel, mkReturnInfoLabel,
47 mkErrorStdEntryLabel, mkClosureTblLabel
49 import ClosureInfo ( mkLFArgument )
50 import CmdLineOpts ( opt_SccProfilingOn, opt_GranMacros )
51 import CostCentre ( CostCentre )
52 import CoreSyn ( isDeadBinder )
53 import Id ( Id, idPrimRep )
54 import DataCon ( DataCon, dataConTag, fIRST_TAG, ConTag,
55 isUnboxedTupleCon, dataConType )
56 import VarSet ( varSetElems )
57 import Const ( Con(..), Literal )
58 import PrimOp ( primOpOutOfLine, PrimOp(..) )
59 import PrimRep ( getPrimRepSize, retPrimRepSize, PrimRep(..)
61 import TyCon ( TyCon, isEnumerationTyCon, isUnboxedTupleTyCon,
62 isNewTyCon, isAlgTyCon, isFunTyCon, isPrimTyCon,
63 tyConDataCons, tyConFamilySize )
64 import Type ( Type, typePrimRep, splitAlgTyConApp,
65 splitTyConApp_maybe, splitRepTyConApp_maybe )
66 import Unique ( Unique, Uniquable(..), mkBuiltinUnique )
67 import Maybes ( maybeToBool )
74 = GCMayHappen -- The scrutinee may involve GC, so everything must be
75 -- tidy before the code for the scrutinee.
77 | NoGC -- The scrutinee is a primitive value, or a call to a
78 -- primitive op which does no GC. Hence the case can
79 -- be done inline, without tidying up first.
82 It is quite interesting to decide whether to put a heap-check
83 at the start of each alternative. Of course we certainly have
84 to do so if the case forces an evaluation, or if there is a primitive
85 op which can trigger GC.
87 A more interesting situation is this:
94 default -> !C!; ...C...
97 where \tr{!x!} indicates a possible heap-check point. The heap checks
98 in the alternatives {\em can} be omitted, in which case the topmost
99 heapcheck will take their worst case into account.
101 In favour of omitting \tr{!B!}, \tr{!C!}:
103 - {\em May} save a heap overflow test,
104 if ...A... allocates anything. The other advantage
105 of this is that we can use relative addressing
106 from a single Hp to get at all the closures so allocated.
108 - No need to save volatile vars etc across the case
112 - May do more allocation than reqd. This sometimes bites us
113 badly. For example, nfib (ha!) allocates about 30\% more space if the
114 worst-casing is done, because many many calls to nfib are leaf calls
115 which don't need to allocate anything.
117 This never hurts us if there is only one alternative.
129 Special case #1: PrimOps returning enumeration types.
131 For enumeration types, we invent a temporary (builtin-unique 1) to
132 hold the tag, and cross our fingers that this doesn't clash with
133 anything else. Builtin-unique 0 is used for a similar reason when
134 compiling enumerated-type primops in CgExpr.lhs. We can't use the
135 unique from the case binder, because this is used to hold the actual
136 closure (when the case binder is live, that is).
138 There is an extra special case for
143 which generates no code for the primop, unless x is used in the
144 alternatives (in which case we lookup the tag in the relevant closure
145 table to get the closure).
148 cgCase (StgCon (PrimOp op) args res_ty)
149 live_in_whole_case live_in_alts bndr srt (StgAlgAlts ty alts deflt)
150 | isEnumerationTyCon tycon
151 = getArgAmodes args `thenFC` \ arg_amodes ->
153 let tag_amode = case op of
154 TagToEnumOp -> only arg_amodes
155 _ -> CTemp (mkBuiltinUnique 1) IntRep
157 closure = CVal (CIndex (CLbl (mkClosureTblLabel tycon) PtrRep) tag_amode PtrRep) PtrRep
161 TagToEnumOp -> nopC; -- no code!
163 _ -> -- Perform the operation
164 getVolatileRegs live_in_alts `thenFC` \ vol_regs ->
166 absC (COpStmt [tag_amode] op
167 arg_amodes -- note: no liveness arg
171 -- bind the default binder if necessary
172 (if (isDeadBinder bndr)
174 else bindNewToTemp bndr `thenFC` \ bndr_amode ->
175 absC (CAssign bndr_amode closure))
179 cgAlgAlts NoGC uniq Nothing{-cc_slot-} False{-no semi-tagging-}
180 False{-not poly case-} alts deflt
181 False{-don't emit yield-} `thenFC` \ (tagged_alts, deflt_c) ->
184 absC (mkAlgAltsCSwitch tag_amode tagged_alts deflt_c)
187 (Just (tycon,_)) = splitTyConApp_maybe res_ty
188 uniq = getUnique bndr
191 Special case #2: inline PrimOps.
194 cgCase (StgCon (PrimOp op) args res_ty)
195 live_in_whole_case live_in_alts bndr srt alts
196 | not (primOpOutOfLine op)
198 -- Get amodes for the arguments and results
199 getArgAmodes args `thenFC` \ arg_amodes ->
201 result_amodes = getPrimAppResultAmodes (getUnique bndr) alts
203 -- Perform the operation
204 getVolatileRegs live_in_alts `thenFC` \ vol_regs ->
206 absC (COpStmt result_amodes op
207 arg_amodes -- note: no liveness arg
210 -- Scrutinise the result
211 cgInlineAlts bndr alts
214 TODO: Case-of-case of primop can probably be done inline too (but
215 maybe better to translate it out beforehand). See
216 ghc/lib/misc/PackedString.lhs for examples where this crops up (with
219 Another special case: scrutinising a primitive-typed variable. No
220 evaluation required. We don't save volatile variables, nor do we do a
221 heap-check in the alternatives. Instead, the heap usage of the
222 alternatives is worst-cased and passed upstream. This can result in
223 allocating more heap than strictly necessary, but it will sometimes
224 eliminate a heap check altogether.
227 cgCase (StgApp v []) live_in_whole_case live_in_alts bndr srt
228 (StgPrimAlts ty alts deflt)
231 getCAddrMode v `thenFC` \amode ->
234 Careful! we can't just bind the default binder to the same thing
235 as the scrutinee, since it might be a stack location, and having
236 two bindings pointing at the same stack locn doesn't work (it
237 confuses nukeDeadBindings). Hence, use a new temp.
239 bindNewToTemp bndr `thenFC` \deflt_amode ->
240 absC (CAssign deflt_amode amode) `thenC`
242 cgPrimAlts NoGC amode alts deflt []
245 Special case: scrutinising a non-primitive variable.
246 This can be done a little better than the general case, because
247 we can reuse/trim the stack slot holding the variable (if it is in one).
250 cgCase (StgApp fun args)
251 live_in_whole_case live_in_alts bndr srt alts@(StgAlgAlts ty _ _)
253 getCAddrModeAndInfo fun `thenFC` \ (fun_amode, lf_info) ->
254 getArgAmodes args `thenFC` \ arg_amodes ->
256 -- Squish the environment
257 nukeDeadBindings live_in_alts `thenC`
258 saveVolatileVarsAndRegs live_in_alts
259 `thenFC` \ (save_assts, alts_eob_info, maybe_cc_slot) ->
261 allocStackTop retPrimRepSize `thenFC` \_ ->
263 forkEval alts_eob_info nopC (
264 deAllocStackTop retPrimRepSize `thenFC` \_ ->
265 cgEvalAlts maybe_cc_slot bndr srt alts)
266 `thenFC` \ scrut_eob_info ->
268 let real_scrut_eob_info =
270 then reserveSeqFrame scrut_eob_info
274 setEndOfBlockInfo real_scrut_eob_info (
275 tailCallFun fun fun_amode lf_info arg_amodes save_assts
279 not_con_ty = case (getScrutineeTyCon ty) of
284 Note about return addresses: we *always* push a return address, even
285 if because of an optimisation we end up jumping direct to the return
286 code (not through the address itself). The alternatives always assume
287 that the return address is on the stack. The return address is
288 required in case the alternative performs a heap check, since it
289 encodes the liveness of the slots in the activation record.
291 On entry to the case alternative, we can re-use the slot containing
292 the return address immediately after the heap check. That's what the
293 deAllocStackTop call is doing above.
295 Finally, here is the general case.
298 cgCase expr live_in_whole_case live_in_alts bndr srt alts
299 = -- Figure out what volatile variables to save
300 nukeDeadBindings live_in_whole_case `thenC`
302 saveVolatileVarsAndRegs live_in_alts
303 `thenFC` \ (save_assts, alts_eob_info, maybe_cc_slot) ->
305 -- Save those variables right now!
306 absC save_assts `thenC`
308 -- generate code for the alts
309 forkEval alts_eob_info
311 nukeDeadBindings live_in_alts `thenC`
312 allocStackTop retPrimRepSize -- space for retn address
315 (deAllocStackTop retPrimRepSize `thenFC` \_ ->
316 cgEvalAlts maybe_cc_slot bndr srt alts) `thenFC` \ scrut_eob_info ->
318 let real_scrut_eob_info =
320 then reserveSeqFrame scrut_eob_info
324 setEndOfBlockInfo real_scrut_eob_info (cgExpr expr)
327 not_con_ty = case (getScrutineeTyCon (alts_ty alts)) of
332 There's a lot of machinery going on behind the scenes to manage the
333 stack pointer here. forkEval takes the virtual Sp and free list from
334 the first argument, and turns that into the *real* Sp for the second
335 argument. It also uses this virtual Sp as the args-Sp in the EOB info
336 returned, so that the scrutinee will trim the real Sp back to the
337 right place before doing whatever it does.
338 --SDM (who just spent an hour figuring this out, and didn't want to
341 Why don't we push the return address just before evaluating the
342 scrutinee? Because the slot reserved for the return address might
343 contain something useful, so we wait until performing a tail call or
344 return before pushing the return address (see
345 CgTailCall.pushReturnAddress).
347 This also means that the environment doesn't need to know about the
348 free stack slot for the return address (for generating bitmaps),
349 because we don't reserve it until just before the eval.
351 TODO!! Problem: however, we have to save the current cost centre
352 stack somewhere, because at the eval point the current CCS might be
353 different. So we pick a free stack slot and save CCCS in it. The
354 problem with this is that this slot isn't recorded as free/unboxed in
355 the environment, so a case expression in the scrutinee will have the
356 wrong bitmap attached. Fortunately we don't ever seem to see
357 case-of-case at the back end. One solution might be to shift the
358 saved CCS to the correct place in the activation record just before
362 (one consequence of the above is that activation records on the stack
363 don't follow the layout of closures when we're profiling. The CCS
364 could be anywhere within the record).
367 alts_ty (StgAlgAlts ty _ _) = ty
368 alts_ty (StgPrimAlts ty _ _) = ty
371 %************************************************************************
373 \subsection[CgCase-primops]{Primitive applications}
375 %************************************************************************
377 Get result amodes for a primitive operation, in the case wher GC can't happen.
378 The amodes are returned in canonical order, ready for the prim-op!
380 Alg case: temporaries named as in the alternatives,
381 plus (CTemp u) for the tag (if needed)
384 This is all disgusting, because these amodes must be consistent with those
385 invented by CgAlgAlts.
388 getPrimAppResultAmodes
393 getPrimAppResultAmodes uniq (StgAlgAlts ty alts some_default)
395 | isUnboxedTupleTyCon tycon =
397 [(con, args, use_mask, rhs)] ->
398 [ CTemp (getUnique arg) (idPrimRep arg) | arg <- args ]
399 _ -> panic "getPrimAppResultAmodes: case of unboxed tuple has multiple branches"
401 | otherwise = panic ("getPrimAppResultAmodes: case of primop has strange type: " ++ showSDoc (ppr ty))
403 where (tycon, _, _) = splitAlgTyConApp ty
405 -- The situation is simpler for primitive results, because there is only
408 getPrimAppResultAmodes uniq (StgPrimAlts ty _ _)
409 = [CTemp uniq (typePrimRep ty)]
413 %************************************************************************
415 \subsection[CgCase-alts]{Alternatives}
417 %************************************************************************
419 @cgEvalAlts@ returns an addressing mode for a continuation for the
420 alternatives of a @case@, used in a context when there
421 is some evaluation to be done.
424 cgEvalAlts :: Maybe VirtualSpOffset -- Offset of cost-centre to be restored, if any
426 -> SRT -- SRT for the continuation
428 -> FCode Sequel -- Any addr modes inside are guaranteed
429 -- to be a label so that we can duplicate it
430 -- without risk of duplicating code
432 cgEvalAlts cc_slot bndr srt alts
434 let uniq = getUnique bndr in
436 buildContLivenessMask uniq `thenFC` \ liveness_mask ->
440 -- algebraic alts ...
441 (StgAlgAlts ty alts deflt) ->
443 -- bind the default binder (it covers all the alternatives)
444 bindNewToReg bndr node mkLFArgument `thenC`
446 -- Generate sequel info for use downstream
447 -- At the moment, we only do it if the type is vector-returnable.
448 -- Reason: if not, then it costs extra to label the
449 -- alternatives, because we'd get return code like:
451 -- switch TagReg { 0 : JMP(alt_1); 1 : JMP(alt_2) ..etc }
453 -- which is worse than having the alt code in the switch statement
455 let tycon_info = getScrutineeTyCon ty
456 is_alg = maybeToBool tycon_info
457 Just spec_tycon = tycon_info
460 -- deal with the unboxed tuple case
461 if is_alg && isUnboxedTupleTyCon spec_tycon then
463 [alt] -> let lbl = mkReturnInfoLabel uniq in
464 cgUnboxedTupleAlt uniq cc_slot True alt
466 getSRTLabel `thenFC` \srt_label ->
467 absC (CRetDirect uniq abs_c (srt_label, srt)
468 liveness_mask) `thenC`
469 returnFC (CaseAlts (CLbl lbl RetRep) Nothing)
470 _ -> panic "cgEvalAlts: dodgy case of unboxed tuple type"
472 -- normal algebraic (or polymorphic) case alternatives
474 ret_conv | is_alg = ctrlReturnConvAlg spec_tycon
475 | otherwise = UnvectoredReturn 0
477 use_labelled_alts = case ret_conv of
478 VectoredReturn _ -> True
482 = if use_labelled_alts then
483 cgSemiTaggedAlts bndr alts deflt -- Just <something>
485 Nothing -- no semi-tagging info
488 cgAlgAlts GCMayHappen uniq cc_slot use_labelled_alts (not is_alg)
489 alts deflt True `thenFC` \ (tagged_alt_absCs, deflt_absC) ->
491 mkReturnVector uniq tagged_alt_absCs deflt_absC srt liveness_mask
492 ret_conv `thenFC` \ return_vec ->
494 returnFC (CaseAlts return_vec semi_tagged_stuff)
497 (StgPrimAlts ty alts deflt) ->
499 -- Restore the cost centre
500 restoreCurrentCostCentre cc_slot `thenFC` \ cc_restore ->
502 -- Generate the switch
503 getAbsC (cgPrimEvalAlts bndr ty alts deflt) `thenFC` \ abs_c ->
505 -- Generate the labelled block, starting with restore-cost-centre
506 getSRTLabel `thenFC` \srt_label ->
507 absC (CRetDirect uniq (cc_restore `mkAbsCStmts` abs_c)
508 (srt_label,srt) liveness_mask) `thenC`
510 -- Return an amode for the block
511 returnFC (CaseAlts (CLbl (mkReturnInfoLabel uniq) RetRep) Nothing)
521 HWL comment on {\em GrAnSim\/} (adding GRAN_YIELDs for context switch): If
522 we do an inlining of the case no separate functions for returning are
523 created, so we don't have to generate a GRAN_YIELD in that case. This info
524 must be propagated to cgAlgAltRhs (where the GRAN_YIELD macro might be
525 emitted). Hence, the new Bool arg to cgAlgAltRhs.
527 First case: primitive op returns an unboxed tuple.
530 cgInlineAlts bndr (StgAlgAlts ty [alt@(con,args,use_mask,rhs)] StgNoDefault)
531 | isUnboxedTupleCon con
532 = -- no heap check, no yield, just get in there and do it.
533 mapFCs bindNewToTemp args `thenFC` \ _ ->
537 = panic "cgInlineAlts: single alternative, not an unboxed tuple"
540 Third (real) case: primitive result type.
543 cgInlineAlts bndr (StgPrimAlts ty alts deflt)
544 = cgPrimInlineAlts bndr ty alts deflt
547 %************************************************************************
549 \subsection[CgCase-alg-alts]{Algebraic alternatives}
551 %************************************************************************
553 In @cgAlgAlts@, none of the binders in the alternatives are
554 assumed to be yet bound.
556 HWL comment on {\em GrAnSim\/} (adding GRAN_YIELDs for context switch): The
557 last arg of cgAlgAlts indicates if we want a context switch at the
558 beginning of each alternative. Normally we want that. The only exception
559 are inlined alternatives.
564 -> Maybe VirtualSpOffset
565 -> Bool -- True <=> branches must be labelled
566 -> Bool -- True <=> polymorphic case
567 -> [(DataCon, [Id], [Bool], StgExpr)] -- The alternatives
568 -> StgCaseDefault -- The default
569 -> Bool -- Context switch at alts?
570 -> FCode ([(ConTag, AbstractC)], -- The branches
571 AbstractC -- The default case
574 cgAlgAlts gc_flag uniq restore_cc must_label_branches is_fun alts deflt
575 emit_yield{-should a yield macro be emitted?-}
577 = forkAlts (map (cgAlgAlt gc_flag uniq restore_cc must_label_branches emit_yield) alts)
578 (cgAlgDefault gc_flag is_fun uniq restore_cc must_label_branches deflt emit_yield)
582 cgAlgDefault :: GCFlag
583 -> Bool -- could be a function-typed result?
584 -> Unique -> Maybe VirtualSpOffset -> Bool -- turgid state...
585 -> StgCaseDefault -- input
587 -> FCode AbstractC -- output
589 cgAlgDefault gc_flag is_fun uniq cc_slot must_label_branch StgNoDefault _
592 cgAlgDefault gc_flag is_fun uniq cc_slot must_label_branch
594 emit_yield{-should a yield macro be emitted?-}
596 = -- We have arranged that Node points to the thing
597 restoreCurrentCostCentre cc_slot `thenFC` \restore_cc ->
598 getAbsC (absC restore_cc `thenC`
599 (if opt_GranMacros && emit_yield
600 then yield [node] False
601 else absC AbsCNop) `thenC`
602 possibleHeapCheck gc_flag is_fun [node] [] Nothing (cgExpr rhs)
603 -- Node is live, but doesn't need to point at the thing itself;
604 -- it's ok for Node to point to an indirection or FETCH_ME
605 -- Hence no need to re-enter Node.
606 ) `thenFC` \ abs_c ->
609 final_abs_c | must_label_branch = CCodeBlock lbl abs_c
614 lbl = mkDefaultLabel uniq
616 -- HWL comment on GrAnSim: GRAN_YIELDs needed; emitted in cgAlgAltRhs
619 -> Unique -> Maybe VirtualSpOffset -> Bool -- turgid state
620 -> Bool -- Context switch at alts?
621 -> (DataCon, [Id], [Bool], StgExpr)
622 -> FCode (ConTag, AbstractC)
624 cgAlgAlt gc_flag uniq cc_slot must_label_branch
625 emit_yield{-should a yield macro be emitted?-}
626 (con, args, use_mask, rhs)
628 restoreCurrentCostCentre cc_slot `thenFC` \restore_cc ->
629 getAbsC (absC restore_cc `thenC`
630 (if opt_GranMacros && emit_yield
631 then yield [node] True -- XXX live regs wrong
632 else absC AbsCNop) `thenC`
634 NoGC -> mapFCs bindNewToTemp args `thenFC` \_ -> nopC
635 GCMayHappen -> bindConArgs con args
637 possibleHeapCheck gc_flag False [node] [] Nothing (
639 ) `thenFC` \ abs_c ->
641 final_abs_c | must_label_branch = CCodeBlock lbl abs_c
644 returnFC (tag, final_abs_c)
647 lbl = mkAltLabel uniq tag
650 :: Unique -- unique for label of the alternative
651 -> Maybe VirtualSpOffset -- Restore cost centre
652 -> Bool -- ctxt switch
653 -> (DataCon, [Id], [Bool], StgExpr) -- alternative
656 cgUnboxedTupleAlt lbl cc_slot emit_yield (con,args,use_mask,rhs)
658 bindUnboxedTupleComponents args
659 `thenFC` \ (live_regs,tags,stack_res) ->
661 restoreCurrentCostCentre cc_slot `thenFC` \restore_cc ->
662 absC restore_cc `thenC`
664 (if opt_GranMacros && emit_yield
665 then yield live_regs True -- XXX live regs wrong?
666 else absC AbsCNop) `thenC`
668 -- ToDo: could maybe use Nothing here if stack_res is False
669 -- since the heap-check can just return to the top of the
674 -- free up stack slots containing tags,
675 freeStackSlots (map fst tags) `thenC`
677 -- generate a heap check if necessary
678 possibleHeapCheck GCMayHappen False live_regs tags ret_addr (
680 -- and finally the code for the alternative
685 %************************************************************************
687 \subsection[CgCase-semi-tagged-alts]{The code to deal with sem-tagging}
689 %************************************************************************
691 Turgid-but-non-monadic code to conjure up the required info from
692 algebraic case alternatives for semi-tagging.
695 cgSemiTaggedAlts :: Id
696 -> [(DataCon, [Id], [Bool], StgExpr)]
697 -> GenStgCaseDefault Id Id
700 cgSemiTaggedAlts binder alts deflt
701 = Just (map st_alt alts, st_deflt deflt)
703 uniq = getUnique binder
705 st_deflt StgNoDefault = Nothing
707 st_deflt (StgBindDefault _)
709 (CCallProfCtrMacro SLIT("RET_SEMI_BY_DEFAULT") [], -- ToDo: monadise?
713 st_alt (con, args, use_mask, _)
714 = -- Ha! Nothing to do; Node already points to the thing
716 (CCallProfCtrMacro SLIT("RET_SEMI_IN_HEAP") -- ToDo: monadise?
717 [mkIntCLit (length args)], -- how big the thing in the heap is
721 con_tag = dataConTag con
722 join_label = mkAltLabel uniq con_tag
725 %************************************************************************
727 \subsection[CgCase-prim-alts]{Primitive alternatives}
729 %************************************************************************
731 @cgPrimEvalAlts@ and @cgPrimInlineAlts@ generate suitable @CSwitch@es
732 for dealing with the alternatives of a primitive @case@, given an
733 addressing mode for the thing to scrutinise. It also keeps track of
734 the maximum stack depth encountered down any branch.
736 As usual, no binders in the alternatives are yet bound.
739 cgPrimInlineAlts bndr ty alts deflt
740 = cgPrimAltsWithDefault bndr NoGC (CTemp uniq kind) alts deflt []
742 uniq = getUnique bndr
743 kind = typePrimRep ty
745 cgPrimEvalAlts bndr ty alts deflt
746 = cgPrimAltsWithDefault bndr GCMayHappen (CReg reg) alts deflt [reg]
748 reg = WARN( case kind of { PtrRep -> True; other -> False }, text "cgPrimEE" <+> ppr bndr <+> ppr ty )
749 dataReturnConvPrim kind
750 kind = typePrimRep ty
752 cgPrimAltsWithDefault bndr gc_flag scrutinee alts deflt regs
753 = -- first bind the default if necessary
754 bindNewPrimToAmode bndr scrutinee `thenC`
755 cgPrimAlts gc_flag scrutinee alts deflt regs
757 cgPrimAlts gc_flag scrutinee alts deflt regs
758 = forkAlts (map (cgPrimAlt gc_flag regs) alts)
759 (cgPrimDefault gc_flag regs deflt)
760 `thenFC` \ (alt_absCs, deflt_absC) ->
762 absC (CSwitch scrutinee alt_absCs deflt_absC)
763 -- CSwitch does sensible things with one or zero alternatives
767 -> [MagicId] -- live registers
768 -> (Literal, StgExpr) -- The alternative
769 -> FCode (Literal, AbstractC) -- Its compiled form
771 cgPrimAlt gc_flag regs (lit, rhs)
772 = getAbsC rhs_code `thenFC` \ absC ->
775 rhs_code = possibleHeapCheck gc_flag False regs [] Nothing (cgExpr rhs)
777 cgPrimDefault :: GCFlag
778 -> [MagicId] -- live registers
782 cgPrimDefault gc_flag regs StgNoDefault
783 = panic "cgPrimDefault: No default in prim case"
785 cgPrimDefault gc_flag regs (StgBindDefault rhs)
786 = getAbsC (possibleHeapCheck gc_flag False regs [] Nothing (cgExpr rhs))
790 %************************************************************************
792 \subsection[CgCase-tidy]{Code for tidying up prior to an eval}
794 %************************************************************************
797 saveVolatileVarsAndRegs
798 :: StgLiveVars -- Vars which should be made safe
799 -> FCode (AbstractC, -- Assignments to do the saves
800 EndOfBlockInfo, -- sequel for the alts
801 Maybe VirtualSpOffset) -- Slot for current cost centre
804 saveVolatileVarsAndRegs vars
805 = saveVolatileVars vars `thenFC` \ var_saves ->
806 saveCurrentCostCentre `thenFC` \ (maybe_cc_slot, cc_save) ->
807 getEndOfBlockInfo `thenFC` \ eob_info ->
808 returnFC (mkAbstractCs [var_saves, cc_save],
813 saveVolatileVars :: StgLiveVars -- Vars which should be made safe
814 -> FCode AbstractC -- Assignments to to the saves
816 saveVolatileVars vars
817 = save_em (varSetElems vars)
819 save_em [] = returnFC AbsCNop
822 = getCAddrModeIfVolatile var `thenFC` \ v ->
824 Nothing -> save_em vars -- Non-volatile, so carry on
827 Just vol_amode -> -- Aha! It's volatile
828 save_var var vol_amode `thenFC` \ abs_c ->
829 save_em vars `thenFC` \ abs_cs ->
830 returnFC (abs_c `mkAbsCStmts` abs_cs)
832 save_var var vol_amode
833 = allocPrimStack (getPrimRepSize kind) `thenFC` \ slot ->
834 rebindToStack var slot `thenC`
835 getSpRelOffset slot `thenFC` \ sp_rel ->
836 returnFC (CAssign (CVal sp_rel kind) vol_amode)
838 kind = getAmodeRep vol_amode
841 ---------------------------------------------------------------------------
843 When we save the current cost centre (which is done for lexical
844 scoping), we allocate a free stack location, and return (a)~the
845 virtual offset of the location, to pass on to the alternatives, and
846 (b)~the assignment to do the save (just as for @saveVolatileVars@).
849 saveCurrentCostCentre ::
850 FCode (Maybe VirtualSpOffset, -- Where we decide to store it
851 AbstractC) -- Assignment to save it
853 saveCurrentCostCentre
854 = if not opt_SccProfilingOn then
855 returnFC (Nothing, AbsCNop)
857 allocPrimStack (getPrimRepSize CostCentreRep) `thenFC` \ slot ->
858 dataStackSlots [slot] `thenC`
859 getSpRelOffset slot `thenFC` \ sp_rel ->
861 CAssign (CVal sp_rel CostCentreRep) (CReg CurCostCentre))
863 restoreCurrentCostCentre :: Maybe VirtualSpOffset -> FCode AbstractC
864 restoreCurrentCostCentre Nothing = returnFC AbsCNop
865 restoreCurrentCostCentre (Just slot)
866 = getSpRelOffset slot `thenFC` \ sp_rel ->
867 freeStackSlots [slot] `thenC`
868 returnFC (CCallProfCCMacro SLIT("RESTORE_CCCS") [CVal sp_rel CostCentreRep])
869 -- we use the RESTORE_CCCS macro, rather than just
870 -- assigning into CurCostCentre, in case RESTORE_CCC
871 -- has some sanity-checking in it.
874 %************************************************************************
876 \subsection[CgCase-return-vec]{Building a return vector}
878 %************************************************************************
880 Build a return vector, and return a suitable label addressing
884 mkReturnVector :: Unique
885 -> [(ConTag, AbstractC)] -- Branch codes
886 -> AbstractC -- Default case
887 -> SRT -- continuation's SRT
888 -> Liveness -- stack liveness
889 -> CtrlReturnConvention
892 mkReturnVector uniq tagged_alt_absCs deflt_absC srt liveness ret_conv
893 = getSRTLabel `thenFC` \srt_label ->
895 srt_info = (srt_label, srt)
897 (return_vec_amode, vtbl_body) = case ret_conv of {
899 -- might be a polymorphic case...
900 UnvectoredReturn 0 ->
901 ASSERT(null tagged_alt_absCs)
902 (CLbl ret_label RetRep,
903 absC (CRetDirect uniq deflt_absC (srt_label, srt) liveness));
905 UnvectoredReturn n ->
906 -- find the tag explicitly rather than using tag_reg for now.
907 -- on architectures with lots of regs the tag will be loaded
908 -- into tag_reg by the code doing the returning.
910 tag = CMacroExpr WordRep GET_TAG [CVal (nodeRel 0) DataPtrRep]
912 (CLbl ret_label RetRep,
913 absC (CRetDirect uniq
914 (mkAlgAltsCSwitch tag tagged_alt_absCs deflt_absC)
918 VectoredReturn table_size ->
920 (vector_table, alts_absC) =
921 unzip (map mk_vector_entry [fIRST_TAG .. (table_size+fIRST_TAG-1)])
923 ret_vector = CRetVector vtbl_label
925 (srt_label, srt) liveness
927 (CLbl vtbl_label DataPtrRep,
928 -- alts come first, because we don't want to declare all the symbols
929 absC (mkAbstractCs (mkAbstractCs alts_absC : [deflt_absC,ret_vector]))
934 returnFC return_vec_amode
938 vtbl_label = mkVecTblLabel uniq
939 ret_label = mkReturnInfoLabel uniq
942 case nonemptyAbsC deflt_absC of
943 -- the simplifier might have eliminated a case
944 Nothing -> CLbl mkErrorStdEntryLabel CodePtrRep
945 Just absC@(CCodeBlock lbl _) -> CLbl lbl CodePtrRep
947 mk_vector_entry :: ConTag -> (CAddrMode, AbstractC)
949 = case [ absC | (t, absC) <- tagged_alt_absCs, t == tag ] of
950 [] -> (deflt_lbl, AbsCNop)
951 [absC@(CCodeBlock lbl _)] -> (CLbl lbl CodePtrRep,absC)
952 _ -> panic "mkReturnVector: too many"
955 %************************************************************************
957 \subsection[CgCase-utils]{Utilities for handling case expressions}
959 %************************************************************************
961 @possibleHeapCheck@ tests a flag passed in to decide whether to do a
962 heap check or not. These heap checks are always in a case
963 alternative, so we use altHeapCheck.
968 -> Bool -- True <=> algebraic case
969 -> [MagicId] -- live registers
970 -> [(VirtualSpOffset,Int)] -- stack slots to tag
971 -> Maybe Unique -- return address unique
972 -> Code -- continuation
975 possibleHeapCheck GCMayHappen is_alg regs tags lbl code
976 = altHeapCheck is_alg regs tags AbsCNop lbl code
977 possibleHeapCheck NoGC _ _ tags lbl code
982 getScrutineeTyCon :: Type -> Maybe TyCon
983 getScrutineeTyCon ty =
984 case splitRepTyConApp_maybe ty of
987 if isFunTyCon tc then Nothing else -- not interested in funs
988 if isPrimTyCon tc then Just tc else -- return primitive tycons
989 -- otherwise (algebraic tycons) check the no. of constructors