2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 % $Id: CgCase.lhs,v 1.36 1999/11/01 17:10:06 simonpj 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, repType )
66 import Unique ( Unique, Uniquable(..), mkPseudoUnique1 )
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).
147 Being a bit short of uniques for temporary variables here, we use
148 mkPseudoUnique1 to generate a temporary for the tag. We can't use
149 mkBuiltinUnique, because that occasionally clashes with some
150 temporaries generated for _ccall_GC, amongst others (see CgExpr.lhs).
153 cgCase (StgCon (PrimOp op) args res_ty)
154 live_in_whole_case live_in_alts bndr srt (StgAlgAlts ty alts deflt)
155 | isEnumerationTyCon tycon
156 = getArgAmodes args `thenFC` \ arg_amodes ->
158 let tag_amode = case op of
159 TagToEnumOp -> only arg_amodes
160 _ -> CTemp (mkPseudoUnique1{-see above-} 1) IntRep
162 closure = CVal (CIndex (CLbl (mkClosureTblLabel tycon) PtrRep) tag_amode PtrRep) PtrRep
166 TagToEnumOp -> nopC; -- no code!
168 _ -> -- Perform the operation
169 getVolatileRegs live_in_alts `thenFC` \ vol_regs ->
171 absC (COpStmt [tag_amode] op
172 arg_amodes -- note: no liveness arg
176 -- bind the default binder if necessary
177 -- The deadness info is set by StgVarInfo
178 (if (isDeadBinder bndr)
180 else bindNewToTemp bndr `thenFC` \ bndr_amode ->
181 absC (CAssign bndr_amode closure))
185 cgAlgAlts NoGC uniq Nothing{-cc_slot-} False{-no semi-tagging-}
186 False{-not poly case-} alts deflt
187 False{-don't emit yield-} `thenFC` \ (tagged_alts, deflt_c) ->
190 absC (mkAlgAltsCSwitch tag_amode tagged_alts deflt_c)
193 (Just (tycon,_)) = splitTyConApp_maybe res_ty
194 uniq = getUnique bndr
197 Special case #2: inline PrimOps.
200 cgCase (StgCon (PrimOp op) args res_ty)
201 live_in_whole_case live_in_alts bndr srt alts
202 | not (primOpOutOfLine op)
204 -- Get amodes for the arguments and results
205 getArgAmodes args `thenFC` \ arg_amodes ->
207 result_amodes = getPrimAppResultAmodes (getUnique bndr) alts
209 -- Perform the operation
210 getVolatileRegs live_in_alts `thenFC` \ vol_regs ->
212 absC (COpStmt result_amodes op
213 arg_amodes -- note: no liveness arg
216 -- Scrutinise the result
217 cgInlineAlts bndr alts
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 Another special case: scrutinising a primitive-typed variable. No
226 evaluation required. We don't save volatile variables, nor do we do a
227 heap-check in the alternatives. Instead, the heap usage of the
228 alternatives is worst-cased and passed upstream. This can result in
229 allocating more heap than strictly necessary, but it will sometimes
230 eliminate a heap check altogether.
233 cgCase (StgApp v []) live_in_whole_case live_in_alts bndr srt
234 (StgPrimAlts ty alts deflt)
237 getCAddrMode v `thenFC` \amode ->
240 Careful! we can't just bind the default binder to the same thing
241 as the scrutinee, since it might be a stack location, and having
242 two bindings pointing at the same stack locn doesn't work (it
243 confuses nukeDeadBindings). Hence, use a new temp.
245 bindNewToTemp bndr `thenFC` \deflt_amode ->
246 absC (CAssign deflt_amode amode) `thenC`
248 cgPrimAlts NoGC amode alts deflt []
251 Special case: scrutinising a non-primitive variable.
252 This can be done a little better than the general case, because
253 we can reuse/trim the stack slot holding the variable (if it is in one).
256 cgCase (StgApp fun args)
257 live_in_whole_case live_in_alts bndr srt alts@(StgAlgAlts ty _ _)
259 getCAddrModeAndInfo fun `thenFC` \ (fun_amode, lf_info) ->
260 getArgAmodes args `thenFC` \ arg_amodes ->
262 -- Squish the environment
263 nukeDeadBindings live_in_alts `thenC`
264 saveVolatileVarsAndRegs live_in_alts
265 `thenFC` \ (save_assts, alts_eob_info, maybe_cc_slot) ->
267 allocStackTop retPrimRepSize `thenFC` \_ ->
269 forkEval alts_eob_info nopC (
270 deAllocStackTop retPrimRepSize `thenFC` \_ ->
271 cgEvalAlts maybe_cc_slot bndr srt alts)
272 `thenFC` \ scrut_eob_info ->
274 let real_scrut_eob_info =
276 then reserveSeqFrame scrut_eob_info
280 setEndOfBlockInfo real_scrut_eob_info (
281 tailCallFun fun fun_amode lf_info arg_amodes save_assts
285 not_con_ty = case (getScrutineeTyCon ty) of
290 Note about return addresses: we *always* push a return address, even
291 if because of an optimisation we end up jumping direct to the return
292 code (not through the address itself). The alternatives always assume
293 that the return address is on the stack. The return address is
294 required in case the alternative performs a heap check, since it
295 encodes the liveness of the slots in the activation record.
297 On entry to the case alternative, we can re-use the slot containing
298 the return address immediately after the heap check. That's what the
299 deAllocStackTop call is doing above.
301 Finally, here is the general case.
304 cgCase expr live_in_whole_case live_in_alts bndr srt alts
305 = -- Figure out what volatile variables to save
306 nukeDeadBindings live_in_whole_case `thenC`
308 saveVolatileVarsAndRegs live_in_alts
309 `thenFC` \ (save_assts, alts_eob_info, maybe_cc_slot) ->
311 -- Save those variables right now!
312 absC save_assts `thenC`
314 -- generate code for the alts
315 forkEval alts_eob_info
317 nukeDeadBindings live_in_alts `thenC`
318 allocStackTop retPrimRepSize -- space for retn address
321 (deAllocStackTop retPrimRepSize `thenFC` \_ ->
322 cgEvalAlts maybe_cc_slot bndr srt alts) `thenFC` \ scrut_eob_info ->
324 let real_scrut_eob_info =
326 then reserveSeqFrame scrut_eob_info
330 setEndOfBlockInfo real_scrut_eob_info (cgExpr expr)
333 not_con_ty = case (getScrutineeTyCon (alts_ty alts)) of
338 There's a lot of machinery going on behind the scenes to manage the
339 stack pointer here. forkEval takes the virtual Sp and free list from
340 the first argument, and turns that into the *real* Sp for the second
341 argument. It also uses this virtual Sp as the args-Sp in the EOB info
342 returned, so that the scrutinee will trim the real Sp back to the
343 right place before doing whatever it does.
344 --SDM (who just spent an hour figuring this out, and didn't want to
347 Why don't we push the return address just before evaluating the
348 scrutinee? Because the slot reserved for the return address might
349 contain something useful, so we wait until performing a tail call or
350 return before pushing the return address (see
351 CgTailCall.pushReturnAddress).
353 This also means that the environment doesn't need to know about the
354 free stack slot for the return address (for generating bitmaps),
355 because we don't reserve it until just before the eval.
357 TODO!! Problem: however, we have to save the current cost centre
358 stack somewhere, because at the eval point the current CCS might be
359 different. So we pick a free stack slot and save CCCS in it. The
360 problem with this is that this slot isn't recorded as free/unboxed in
361 the environment, so a case expression in the scrutinee will have the
362 wrong bitmap attached. Fortunately we don't ever seem to see
363 case-of-case at the back end. One solution might be to shift the
364 saved CCS to the correct place in the activation record just before
368 (one consequence of the above is that activation records on the stack
369 don't follow the layout of closures when we're profiling. The CCS
370 could be anywhere within the record).
373 alts_ty (StgAlgAlts ty _ _) = ty
374 alts_ty (StgPrimAlts ty _ _) = ty
377 %************************************************************************
379 \subsection[CgCase-primops]{Primitive applications}
381 %************************************************************************
383 Get result amodes for a primitive operation, in the case wher GC can't happen.
384 The amodes are returned in canonical order, ready for the prim-op!
386 Alg case: temporaries named as in the alternatives,
387 plus (CTemp u) for the tag (if needed)
390 This is all disgusting, because these amodes must be consistent with those
391 invented by CgAlgAlts.
394 getPrimAppResultAmodes
399 getPrimAppResultAmodes uniq (StgAlgAlts ty alts some_default)
401 | isUnboxedTupleTyCon tycon =
403 [(con, args, use_mask, rhs)] ->
404 [ CTemp (getUnique arg) (idPrimRep arg) | arg <- args ]
405 _ -> panic "getPrimAppResultAmodes: case of unboxed tuple has multiple branches"
407 | otherwise = panic ("getPrimAppResultAmodes: case of primop has strange type: " ++ showSDoc (ppr ty))
409 where (tycon, _, _) = splitAlgTyConApp ty
411 -- The situation is simpler for primitive results, because there is only
414 getPrimAppResultAmodes uniq (StgPrimAlts ty _ _)
415 = [CTemp uniq (typePrimRep ty)]
419 %************************************************************************
421 \subsection[CgCase-alts]{Alternatives}
423 %************************************************************************
425 @cgEvalAlts@ returns an addressing mode for a continuation for the
426 alternatives of a @case@, used in a context when there
427 is some evaluation to be done.
430 cgEvalAlts :: Maybe VirtualSpOffset -- Offset of cost-centre to be restored, if any
432 -> SRT -- SRT for the continuation
434 -> FCode Sequel -- Any addr modes inside are guaranteed
435 -- to be a label so that we can duplicate it
436 -- without risk of duplicating code
438 cgEvalAlts cc_slot bndr srt alts
440 let uniq = getUnique bndr in
442 buildContLivenessMask uniq `thenFC` \ liveness_mask ->
446 -- algebraic alts ...
447 (StgAlgAlts ty alts deflt) ->
449 -- bind the default binder (it covers all the alternatives)
450 bindNewToReg bndr node mkLFArgument `thenC`
452 -- Generate sequel info for use downstream
453 -- At the moment, we only do it if the type is vector-returnable.
454 -- Reason: if not, then it costs extra to label the
455 -- alternatives, because we'd get return code like:
457 -- switch TagReg { 0 : JMP(alt_1); 1 : JMP(alt_2) ..etc }
459 -- which is worse than having the alt code in the switch statement
461 let tycon_info = getScrutineeTyCon ty
462 is_alg = maybeToBool tycon_info
463 Just spec_tycon = tycon_info
466 -- deal with the unboxed tuple case
467 if is_alg && isUnboxedTupleTyCon spec_tycon then
469 [alt] -> let lbl = mkReturnInfoLabel uniq in
470 cgUnboxedTupleAlt uniq cc_slot True alt
472 getSRTLabel `thenFC` \srt_label ->
473 absC (CRetDirect uniq abs_c (srt_label, srt)
474 liveness_mask) `thenC`
475 returnFC (CaseAlts (CLbl lbl RetRep) Nothing)
476 _ -> panic "cgEvalAlts: dodgy case of unboxed tuple type"
478 -- normal algebraic (or polymorphic) case alternatives
480 ret_conv | is_alg = ctrlReturnConvAlg spec_tycon
481 | otherwise = UnvectoredReturn 0
483 use_labelled_alts = case ret_conv of
484 VectoredReturn _ -> True
488 = if use_labelled_alts then
489 cgSemiTaggedAlts bndr alts deflt -- Just <something>
491 Nothing -- no semi-tagging info
494 cgAlgAlts GCMayHappen uniq cc_slot use_labelled_alts (not is_alg)
495 alts deflt True `thenFC` \ (tagged_alt_absCs, deflt_absC) ->
497 mkReturnVector uniq tagged_alt_absCs deflt_absC srt liveness_mask
498 ret_conv `thenFC` \ return_vec ->
500 returnFC (CaseAlts return_vec semi_tagged_stuff)
503 (StgPrimAlts ty alts deflt) ->
505 -- Restore the cost centre
506 restoreCurrentCostCentre cc_slot `thenFC` \ cc_restore ->
508 -- Generate the switch
509 getAbsC (cgPrimEvalAlts bndr ty alts deflt) `thenFC` \ abs_c ->
511 -- Generate the labelled block, starting with restore-cost-centre
512 getSRTLabel `thenFC` \srt_label ->
513 absC (CRetDirect uniq (cc_restore `mkAbsCStmts` abs_c)
514 (srt_label,srt) liveness_mask) `thenC`
516 -- Return an amode for the block
517 returnFC (CaseAlts (CLbl (mkReturnInfoLabel uniq) RetRep) Nothing)
527 HWL comment on {\em GrAnSim\/} (adding GRAN_YIELDs for context switch): If
528 we do an inlining of the case no separate functions for returning are
529 created, so we don't have to generate a GRAN_YIELD in that case. This info
530 must be propagated to cgAlgAltRhs (where the GRAN_YIELD macro might be
531 emitted). Hence, the new Bool arg to cgAlgAltRhs.
533 First case: primitive op returns an unboxed tuple.
536 cgInlineAlts bndr (StgAlgAlts ty [alt@(con,args,use_mask,rhs)] StgNoDefault)
537 | isUnboxedTupleCon con
538 = -- no heap check, no yield, just get in there and do it.
539 mapFCs bindNewToTemp args `thenFC` \ _ ->
543 = panic "cgInlineAlts: single alternative, not an unboxed tuple"
546 Third (real) case: primitive result type.
549 cgInlineAlts bndr (StgPrimAlts ty alts deflt)
550 = cgPrimInlineAlts bndr ty alts deflt
553 %************************************************************************
555 \subsection[CgCase-alg-alts]{Algebraic alternatives}
557 %************************************************************************
559 In @cgAlgAlts@, none of the binders in the alternatives are
560 assumed to be yet bound.
562 HWL comment on {\em GrAnSim\/} (adding GRAN_YIELDs for context switch): The
563 last arg of cgAlgAlts indicates if we want a context switch at the
564 beginning of each alternative. Normally we want that. The only exception
565 are inlined alternatives.
570 -> Maybe VirtualSpOffset
571 -> Bool -- True <=> branches must be labelled
572 -> Bool -- True <=> polymorphic case
573 -> [(DataCon, [Id], [Bool], StgExpr)] -- The alternatives
574 -> StgCaseDefault -- The default
575 -> Bool -- Context switch at alts?
576 -> FCode ([(ConTag, AbstractC)], -- The branches
577 AbstractC -- The default case
580 cgAlgAlts gc_flag uniq restore_cc must_label_branches is_fun alts deflt
581 emit_yield{-should a yield macro be emitted?-}
583 = forkAlts (map (cgAlgAlt gc_flag uniq restore_cc must_label_branches emit_yield) alts)
584 (cgAlgDefault gc_flag is_fun uniq restore_cc must_label_branches deflt emit_yield)
588 cgAlgDefault :: GCFlag
589 -> Bool -- could be a function-typed result?
590 -> Unique -> Maybe VirtualSpOffset -> Bool -- turgid state...
591 -> StgCaseDefault -- input
593 -> FCode AbstractC -- output
595 cgAlgDefault gc_flag is_fun uniq cc_slot must_label_branch StgNoDefault _
598 cgAlgDefault gc_flag is_fun uniq cc_slot must_label_branch
600 emit_yield{-should a yield macro be emitted?-}
602 = -- We have arranged that Node points to the thing
603 restoreCurrentCostCentre cc_slot `thenFC` \restore_cc ->
604 getAbsC (absC restore_cc `thenC`
605 (if opt_GranMacros && emit_yield
606 then yield [node] False
607 else absC AbsCNop) `thenC`
608 possibleHeapCheck gc_flag is_fun [node] [] Nothing (cgExpr rhs)
609 -- Node is live, but doesn't need to point at the thing itself;
610 -- it's ok for Node to point to an indirection or FETCH_ME
611 -- Hence no need to re-enter Node.
612 ) `thenFC` \ abs_c ->
615 final_abs_c | must_label_branch = CCodeBlock lbl abs_c
620 lbl = mkDefaultLabel uniq
622 -- HWL comment on GrAnSim: GRAN_YIELDs needed; emitted in cgAlgAltRhs
625 -> Unique -> Maybe VirtualSpOffset -> Bool -- turgid state
626 -> Bool -- Context switch at alts?
627 -> (DataCon, [Id], [Bool], StgExpr)
628 -> FCode (ConTag, AbstractC)
630 cgAlgAlt gc_flag uniq cc_slot must_label_branch
631 emit_yield{-should a yield macro be emitted?-}
632 (con, args, use_mask, rhs)
634 restoreCurrentCostCentre cc_slot `thenFC` \restore_cc ->
635 getAbsC (absC restore_cc `thenC`
636 (if opt_GranMacros && emit_yield
637 then yield [node] True -- XXX live regs wrong
638 else absC AbsCNop) `thenC`
640 NoGC -> mapFCs bindNewToTemp args `thenFC` \_ -> nopC
641 GCMayHappen -> bindConArgs con args
643 possibleHeapCheck gc_flag False [node] [] Nothing (
645 ) `thenFC` \ abs_c ->
647 final_abs_c | must_label_branch = CCodeBlock lbl abs_c
650 returnFC (tag, final_abs_c)
653 lbl = mkAltLabel uniq tag
656 :: Unique -- unique for label of the alternative
657 -> Maybe VirtualSpOffset -- Restore cost centre
658 -> Bool -- ctxt switch
659 -> (DataCon, [Id], [Bool], StgExpr) -- alternative
662 cgUnboxedTupleAlt lbl cc_slot emit_yield (con,args,use_mask,rhs)
664 bindUnboxedTupleComponents args
665 `thenFC` \ (live_regs,tags,stack_res) ->
667 restoreCurrentCostCentre cc_slot `thenFC` \restore_cc ->
668 absC restore_cc `thenC`
670 (if opt_GranMacros && emit_yield
671 then yield live_regs True -- XXX live regs wrong?
672 else absC AbsCNop) `thenC`
674 -- ToDo: could maybe use Nothing here if stack_res is False
675 -- since the heap-check can just return to the top of the
680 -- free up stack slots containing tags,
681 freeStackSlots (map fst tags) `thenC`
683 -- generate a heap check if necessary
684 possibleHeapCheck GCMayHappen False live_regs tags ret_addr (
686 -- and finally the code for the alternative
691 %************************************************************************
693 \subsection[CgCase-semi-tagged-alts]{The code to deal with sem-tagging}
695 %************************************************************************
697 Turgid-but-non-monadic code to conjure up the required info from
698 algebraic case alternatives for semi-tagging.
701 cgSemiTaggedAlts :: Id
702 -> [(DataCon, [Id], [Bool], StgExpr)]
703 -> GenStgCaseDefault Id Id
706 cgSemiTaggedAlts binder alts deflt
707 = Just (map st_alt alts, st_deflt deflt)
709 uniq = getUnique binder
711 st_deflt StgNoDefault = Nothing
713 st_deflt (StgBindDefault _)
715 (CCallProfCtrMacro SLIT("RET_SEMI_BY_DEFAULT") [], -- ToDo: monadise?
719 st_alt (con, args, use_mask, _)
720 = -- Ha! Nothing to do; Node already points to the thing
722 (CCallProfCtrMacro SLIT("RET_SEMI_IN_HEAP") -- ToDo: monadise?
723 [mkIntCLit (length args)], -- how big the thing in the heap is
727 con_tag = dataConTag con
728 join_label = mkAltLabel uniq con_tag
731 %************************************************************************
733 \subsection[CgCase-prim-alts]{Primitive alternatives}
735 %************************************************************************
737 @cgPrimEvalAlts@ and @cgPrimInlineAlts@ generate suitable @CSwitch@es
738 for dealing with the alternatives of a primitive @case@, given an
739 addressing mode for the thing to scrutinise. It also keeps track of
740 the maximum stack depth encountered down any branch.
742 As usual, no binders in the alternatives are yet bound.
745 cgPrimInlineAlts bndr ty alts deflt
746 = cgPrimAltsWithDefault bndr NoGC (CTemp uniq kind) alts deflt []
748 uniq = getUnique bndr
749 kind = typePrimRep ty
751 cgPrimEvalAlts bndr ty alts deflt
752 = cgPrimAltsWithDefault bndr GCMayHappen (CReg reg) alts deflt [reg]
754 reg = WARN( case kind of { PtrRep -> True; other -> False }, text "cgPrimEE" <+> ppr bndr <+> ppr ty )
755 dataReturnConvPrim kind
756 kind = typePrimRep ty
758 cgPrimAltsWithDefault bndr gc_flag scrutinee alts deflt regs
759 = -- first bind the default if necessary
760 bindNewPrimToAmode bndr scrutinee `thenC`
761 cgPrimAlts gc_flag scrutinee alts deflt regs
763 cgPrimAlts gc_flag scrutinee alts deflt regs
764 = forkAlts (map (cgPrimAlt gc_flag regs) alts)
765 (cgPrimDefault gc_flag regs deflt)
766 `thenFC` \ (alt_absCs, deflt_absC) ->
768 absC (CSwitch scrutinee alt_absCs deflt_absC)
769 -- CSwitch does sensible things with one or zero alternatives
773 -> [MagicId] -- live registers
774 -> (Literal, StgExpr) -- The alternative
775 -> FCode (Literal, AbstractC) -- Its compiled form
777 cgPrimAlt gc_flag regs (lit, rhs)
778 = getAbsC rhs_code `thenFC` \ absC ->
781 rhs_code = possibleHeapCheck gc_flag False regs [] Nothing (cgExpr rhs)
783 cgPrimDefault :: GCFlag
784 -> [MagicId] -- live registers
788 cgPrimDefault gc_flag regs StgNoDefault
789 = panic "cgPrimDefault: No default in prim case"
791 cgPrimDefault gc_flag regs (StgBindDefault rhs)
792 = getAbsC (possibleHeapCheck gc_flag False regs [] Nothing (cgExpr rhs))
796 %************************************************************************
798 \subsection[CgCase-tidy]{Code for tidying up prior to an eval}
800 %************************************************************************
803 saveVolatileVarsAndRegs
804 :: StgLiveVars -- Vars which should be made safe
805 -> FCode (AbstractC, -- Assignments to do the saves
806 EndOfBlockInfo, -- sequel for the alts
807 Maybe VirtualSpOffset) -- Slot for current cost centre
810 saveVolatileVarsAndRegs vars
811 = saveVolatileVars vars `thenFC` \ var_saves ->
812 saveCurrentCostCentre `thenFC` \ (maybe_cc_slot, cc_save) ->
813 getEndOfBlockInfo `thenFC` \ eob_info ->
814 returnFC (mkAbstractCs [var_saves, cc_save],
819 saveVolatileVars :: StgLiveVars -- Vars which should be made safe
820 -> FCode AbstractC -- Assignments to to the saves
822 saveVolatileVars vars
823 = save_em (varSetElems vars)
825 save_em [] = returnFC AbsCNop
828 = getCAddrModeIfVolatile var `thenFC` \ v ->
830 Nothing -> save_em vars -- Non-volatile, so carry on
833 Just vol_amode -> -- Aha! It's volatile
834 save_var var vol_amode `thenFC` \ abs_c ->
835 save_em vars `thenFC` \ abs_cs ->
836 returnFC (abs_c `mkAbsCStmts` abs_cs)
838 save_var var vol_amode
839 = allocPrimStack (getPrimRepSize kind) `thenFC` \ slot ->
840 rebindToStack var slot `thenC`
841 getSpRelOffset slot `thenFC` \ sp_rel ->
842 returnFC (CAssign (CVal sp_rel kind) vol_amode)
844 kind = getAmodeRep vol_amode
847 ---------------------------------------------------------------------------
849 When we save the current cost centre (which is done for lexical
850 scoping), we allocate a free stack location, and return (a)~the
851 virtual offset of the location, to pass on to the alternatives, and
852 (b)~the assignment to do the save (just as for @saveVolatileVars@).
855 saveCurrentCostCentre ::
856 FCode (Maybe VirtualSpOffset, -- Where we decide to store it
857 AbstractC) -- Assignment to save it
859 saveCurrentCostCentre
860 = if not opt_SccProfilingOn then
861 returnFC (Nothing, AbsCNop)
863 allocPrimStack (getPrimRepSize CostCentreRep) `thenFC` \ slot ->
864 dataStackSlots [slot] `thenC`
865 getSpRelOffset slot `thenFC` \ sp_rel ->
867 CAssign (CVal sp_rel CostCentreRep) (CReg CurCostCentre))
869 restoreCurrentCostCentre :: Maybe VirtualSpOffset -> FCode AbstractC
870 restoreCurrentCostCentre Nothing = returnFC AbsCNop
871 restoreCurrentCostCentre (Just slot)
872 = getSpRelOffset slot `thenFC` \ sp_rel ->
873 freeStackSlots [slot] `thenC`
874 returnFC (CCallProfCCMacro SLIT("RESTORE_CCCS") [CVal sp_rel CostCentreRep])
875 -- we use the RESTORE_CCCS macro, rather than just
876 -- assigning into CurCostCentre, in case RESTORE_CCC
877 -- has some sanity-checking in it.
880 %************************************************************************
882 \subsection[CgCase-return-vec]{Building a return vector}
884 %************************************************************************
886 Build a return vector, and return a suitable label addressing
890 mkReturnVector :: Unique
891 -> [(ConTag, AbstractC)] -- Branch codes
892 -> AbstractC -- Default case
893 -> SRT -- continuation's SRT
894 -> Liveness -- stack liveness
895 -> CtrlReturnConvention
898 mkReturnVector uniq tagged_alt_absCs deflt_absC srt liveness ret_conv
899 = getSRTLabel `thenFC` \srt_label ->
901 srt_info = (srt_label, srt)
903 (return_vec_amode, vtbl_body) = case ret_conv of {
905 -- might be a polymorphic case...
906 UnvectoredReturn 0 ->
907 ASSERT(null tagged_alt_absCs)
908 (CLbl ret_label RetRep,
909 absC (CRetDirect uniq deflt_absC (srt_label, srt) liveness));
911 UnvectoredReturn n ->
912 -- find the tag explicitly rather than using tag_reg for now.
913 -- on architectures with lots of regs the tag will be loaded
914 -- into tag_reg by the code doing the returning.
916 tag = CMacroExpr WordRep GET_TAG [CVal (nodeRel 0) DataPtrRep]
918 (CLbl ret_label RetRep,
919 absC (CRetDirect uniq
920 (mkAlgAltsCSwitch tag tagged_alt_absCs deflt_absC)
924 VectoredReturn table_size ->
926 (vector_table, alts_absC) =
927 unzip (map mk_vector_entry [fIRST_TAG .. (table_size+fIRST_TAG-1)])
929 ret_vector = CRetVector vtbl_label
931 (srt_label, srt) liveness
933 (CLbl vtbl_label DataPtrRep,
934 -- alts come first, because we don't want to declare all the symbols
935 absC (mkAbstractCs (mkAbstractCs alts_absC : [deflt_absC,ret_vector]))
940 returnFC return_vec_amode
944 vtbl_label = mkVecTblLabel uniq
945 ret_label = mkReturnInfoLabel uniq
948 case nonemptyAbsC deflt_absC of
949 -- the simplifier might have eliminated a case
950 Nothing -> CLbl mkErrorStdEntryLabel CodePtrRep
951 Just absC@(CCodeBlock lbl _) -> CLbl lbl CodePtrRep
953 mk_vector_entry :: ConTag -> (CAddrMode, AbstractC)
955 = case [ absC | (t, absC) <- tagged_alt_absCs, t == tag ] of
956 [] -> (deflt_lbl, AbsCNop)
957 [absC@(CCodeBlock lbl _)] -> (CLbl lbl CodePtrRep,absC)
958 _ -> panic "mkReturnVector: too many"
961 %************************************************************************
963 \subsection[CgCase-utils]{Utilities for handling case expressions}
965 %************************************************************************
967 @possibleHeapCheck@ tests a flag passed in to decide whether to do a
968 heap check or not. These heap checks are always in a case
969 alternative, so we use altHeapCheck.
974 -> Bool -- True <=> algebraic case
975 -> [MagicId] -- live registers
976 -> [(VirtualSpOffset,Int)] -- stack slots to tag
977 -> Maybe Unique -- return address unique
978 -> Code -- continuation
981 possibleHeapCheck GCMayHappen is_alg regs tags lbl code
982 = altHeapCheck is_alg regs tags AbsCNop lbl code
983 possibleHeapCheck NoGC _ _ tags lbl code
988 getScrutineeTyCon :: Type -> Maybe TyCon
989 getScrutineeTyCon ty =
990 case splitTyConApp_maybe (repType ty) of
993 if isFunTyCon tc then Nothing else -- not interested in funs
994 if isPrimTyCon tc then Just tc else -- return primitive tycons
995 -- otherwise (algebraic tycons) check the no. of constructors