2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 % $Id: CgCase.lhs,v 1.19 1998/12/18 17:40:48 simonpj Exp $
6 %********************************************************
8 \section[CgCase]{Converting @StgCase@ expressions}
10 %********************************************************
13 module CgCase ( cgCase, saveVolatileVarsAndRegs, restoreCurrentCostCentre,
14 splitAlgTyConAppThroughNewTypes ) where
16 #include "HsVersions.h"
18 import {-# SOURCE #-} CgExpr ( cgExpr )
24 import AbsCUtils ( mkAbstractCs, mkAbsCStmts, mkAlgAltsCSwitch,
25 getAmodeRep, nonemptyAbsC
27 import CoreSyn ( isDeadBinder )
28 import CgUpdate ( reserveSeqFrame )
29 import CgBindery ( getVolatileRegs, getArgAmodes,
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 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,
63 tyConDataCons, tyConFamilySize )
64 import Type ( Type, typePrimRep, splitAlgTyConApp, splitAlgTyConApp_maybe,
65 splitFunTys, applyTys )
66 import Unique ( Unique, Uniquable(..) )
67 import Maybes ( maybeToBool )
73 = GCMayHappen -- The scrutinee may involve GC, so everything must be
74 -- tidy before the code for the scrutinee.
76 | NoGC -- The scrutinee is a primitive value, or a call to a
77 -- primitive op which does no GC. Hence the case can
78 -- be done inline, without tidying up first.
81 It is quite interesting to decide whether to put a heap-check
82 at the start of each alternative. Of course we certainly have
83 to do so if the case forces an evaluation, or if there is a primitive
84 op which can trigger GC.
86 A more interesting situation is this:
93 default -> !C!; ...C...
96 where \tr{!x!} indicates a possible heap-check point. The heap checks
97 in the alternatives {\em can} be omitted, in which case the topmost
98 heapcheck will take their worst case into account.
100 In favour of omitting \tr{!B!}, \tr{!C!}:
102 - {\em May} save a heap overflow test,
103 if ...A... allocates anything. The other advantage
104 of this is that we can use relative addressing
105 from a single Hp to get at all the closures so allocated.
107 - No need to save volatile vars etc across the case
111 - May do more allocation than reqd. This sometimes bites us
112 badly. For example, nfib (ha!) allocates about 30\% more space if the
113 worst-casing is done, because many many calls to nfib are leaf calls
114 which don't need to allocate anything.
116 This never hurts us if there is only one alternative.
119 *** NOT YET DONE *** The difficulty is that \tr{!B!}, \tr{!C!} need
120 to take account of what is live, and that includes all live volatile
121 variables, even if they also have stable analogues. Furthermore, the
122 stack pointers must be lined up properly so that GC sees tidy stacks.
123 If these things are done, then the heap checks can be done at \tr{!B!} and
124 \tr{!C!} without a full save-volatile-vars sequence.
136 Several special cases for inline primitive operations.
139 cgCase (StgCon (PrimOp op) args res_ty) live_in_whole_case live_in_alts bndr srt alts
140 | not (primOpOutOfLine op)
142 -- Get amodes for the arguments and results
143 getArgAmodes args `thenFC` \ arg_amodes ->
145 result_amodes = getPrimAppResultAmodes (getUnique bndr) alts
147 -- Perform the operation
148 getVolatileRegs live_in_alts `thenFC` \ vol_regs ->
150 absC (COpStmt result_amodes op
151 arg_amodes -- note: no liveness arg
154 -- Scrutinise the result
155 cgInlineAlts bndr alts
158 Another special case: scrutinising a primitive-typed variable. No
159 evaluation required. We don't save volatile variables, nor do we do a
160 heap-check in the alternatives. Instead, the heap usage of the
161 alternatives is worst-cased and passed upstream. This can result in
162 allocating more heap than strictly necessary, but it will sometimes
163 eliminate a heap check altogether.
166 cgCase (StgApp v []) live_in_whole_case live_in_alts bndr srt
167 (StgPrimAlts ty alts deflt)
170 getCAddrMode v `thenFC` \amode ->
173 Careful! we can't just bind the default binder to the same thing
174 as the scrutinee, since it might be a stack location, and having
175 two bindings pointing at the same stack locn doesn't work (it
176 confuses nukeDeadBindings). Hence, use a new temp.
178 (if (isDeadBinder bndr)
180 else bindNewToTemp bndr `thenFC` \deflt_amode ->
181 absC (CAssign deflt_amode amode)) `thenC`
183 cgPrimAlts NoGC amode alts deflt []
186 Special case: scrutinising a non-primitive variable.
187 This can be done a little better than the general case, because
188 we can reuse/trim the stack slot holding the variable (if it is in one).
191 cgCase (StgApp fun args)
192 live_in_whole_case live_in_alts bndr srt alts@(StgAlgAlts ty _ _)
194 getCAddrModeAndInfo fun `thenFC` \ (fun_amode, lf_info) ->
195 getArgAmodes args `thenFC` \ arg_amodes ->
197 -- Squish the environment
198 nukeDeadBindings live_in_alts `thenC`
199 saveVolatileVarsAndRegs live_in_alts
200 `thenFC` \ (save_assts, alts_eob_info, maybe_cc_slot) ->
202 allocStackTop retPrimRepSize `thenFC` \_ ->
204 forkEval alts_eob_info nopC (
205 deAllocStackTop retPrimRepSize `thenFC` \_ ->
206 cgEvalAlts maybe_cc_slot bndr srt alts)
207 `thenFC` \ scrut_eob_info ->
209 let real_scrut_eob_info =
211 then reserveSeqFrame scrut_eob_info
215 setEndOfBlockInfo real_scrut_eob_info (
216 tailCallFun fun fun_amode lf_info arg_amodes save_assts
220 not_con_ty = case (getScrutineeTyCon ty) of
225 Note about return addresses: we *always* push a return address, even
226 if because of an optimisation we end up jumping direct to the return
227 code (not through the address itself). The alternatives always assume
228 that the return address is on the stack. The return address is
229 required in case the alternative performs a heap check, since it
230 encodes the liveness of the slots in the activation record.
232 On entry to the case alternative, we can re-use the slot containing
233 the return address immediately after the heap check. That's what the
234 deAllocStackTop call is doing above.
236 Finally, here is the general case.
239 cgCase expr live_in_whole_case live_in_alts bndr srt alts
240 = -- Figure out what volatile variables to save
241 nukeDeadBindings live_in_whole_case `thenC`
243 saveVolatileVarsAndRegs live_in_alts
244 `thenFC` \ (save_assts, alts_eob_info, maybe_cc_slot) ->
246 -- Save those variables right now!
247 absC save_assts `thenC`
249 -- generate code for the alts
250 forkEval alts_eob_info
252 nukeDeadBindings live_in_alts `thenC`
253 allocStackTop retPrimRepSize -- space for retn address
256 (deAllocStackTop retPrimRepSize `thenFC` \_ ->
257 cgEvalAlts maybe_cc_slot bndr srt alts) `thenFC` \ scrut_eob_info ->
259 let real_scrut_eob_info =
261 then reserveSeqFrame scrut_eob_info
265 setEndOfBlockInfo real_scrut_eob_info (cgExpr expr)
268 not_con_ty = case (getScrutineeTyCon (alts_ty alts)) of
273 There's a lot of machinery going on behind the scenes to manage the
274 stack pointer here. forkEval takes the virtual Sp and free list from
275 the first argument, and turns that into the *real* Sp for the second
276 argument. It also uses this virtual Sp as the args-Sp in the EOB info
277 returned, so that the scrutinee will trim the real Sp back to the
278 right place before doing whatever it does.
279 --SDM (who just spent an hour figuring this out, and didn't want to
282 Why don't we push the return address just before evaluating the
283 scrutinee? Because the slot reserved for the return address might
284 contain something useful, so we wait until performing a tail call or
285 return before pushing the return address (see
286 CgTailCall.pushReturnAddress).
288 This also means that the environment doesn't need to know about the
289 free stack slot for the return address (for generating bitmaps),
290 because we don't reserve it until just before the eval.
292 TODO!! Problem: however, we have to save the current cost centre
293 stack somewhere, because at the eval point the current CCS might be
294 different. So we pick a free stack slot and save CCCS in it. The
295 problem with this is that this slot isn't recorded as free/unboxed in
296 the environment, so a case expression in the scrutinee will have the
297 wrong bitmap attached. Fortunately we don't ever seem to see
298 case-of-case at the back end. One solution might be to shift the
299 saved CCS to the correct place in the activation record just before
303 (one consequence of the above is that activation records on the stack
304 don't follow the layout of closures when we're profiling. The CCS
305 could be anywhere within the record).
308 alts_ty (StgAlgAlts ty _ _) = ty
309 alts_ty (StgPrimAlts ty _ _) = ty
312 %************************************************************************
314 \subsection[CgCase-primops]{Primitive applications}
316 %************************************************************************
318 Get result amodes for a primitive operation, in the case wher GC can't happen.
319 The amodes are returned in canonical order, ready for the prim-op!
321 Alg case: temporaries named as in the alternatives,
322 plus (CTemp u) for the tag (if needed)
325 This is all disgusting, because these amodes must be consistent with those
326 invented by CgAlgAlts.
329 getPrimAppResultAmodes
336 -- If there's an StgBindDefault which does use the bound
337 -- variable, then we can only handle it if the type involved is
338 -- an enumeration type. That's important in the case
344 -- The only reason for the restriction to *enumeration* types is our
345 -- inability to invent suitable temporaries to hold the results;
346 -- Elaborating the CTemp addr mode to have a second uniq field
347 -- (which would simply count from 1) would solve the problem.
348 -- Anyway, cgInlineAlts is now capable of handling all cases;
349 -- it's only this function which is being wimpish.
351 getPrimAppResultAmodes uniq (StgAlgAlts ty alts
352 (StgBindDefault rhs))
353 | isEnumerationTyCon spec_tycon = [tag_amode]
354 | otherwise = pprPanic "getPrimAppResultAmodes: non-enumeration algebraic alternatives with default" (ppr uniq <+> ppr rhs)
356 -- A temporary variable to hold the tag; this is unaffected by GC because
357 -- the heap-checks in the branches occur after the switch
358 tag_amode = CTemp uniq IntRep
359 (spec_tycon, _, _) = splitAlgTyConApp ty
362 If we don't have a default case, we could be scrutinising an unboxed
363 tuple, or an enumeration type...
366 getPrimAppResultAmodes uniq (StgAlgAlts ty alts other_default)
367 -- Default is either StgNoDefault or StgBindDefault with unused binder
369 | isEnumerationTyCon tycon = [CTemp uniq IntRep]
371 | isUnboxedTupleTyCon tycon =
373 [(con, args, use_mask, rhs)] ->
374 [ CTemp (getUnique arg) (idPrimRep arg) | arg <- args ]
375 _ -> panic "getPrimAppResultAmodes: case of unboxed tuple has multiple branches"
377 | otherwise = panic ("getPrimAppResultAmodes: case of primop has strange type: " ++ showSDoc (ppr ty))
379 where (tycon, _, _) = splitAlgTyConApp ty
382 The situation is simpler for primitive results, because there is only
386 getPrimAppResultAmodes uniq (StgPrimAlts ty _ _)
387 = [CTemp uniq (typePrimRep ty)]
391 %************************************************************************
393 \subsection[CgCase-alts]{Alternatives}
395 %************************************************************************
397 @cgEvalAlts@ returns an addressing mode for a continuation for the
398 alternatives of a @case@, used in a context when there
399 is some evaluation to be done.
402 cgEvalAlts :: Maybe VirtualSpOffset -- Offset of cost-centre to be restored, if any
404 -> SRT -- SRT for the continuation
406 -> FCode Sequel -- Any addr modes inside are guaranteed
407 -- to be a label so that we can duplicate it
408 -- without risk of duplicating code
410 cgEvalAlts cc_slot bndr srt alts
412 let uniq = getUnique bndr in
414 -- Generate the instruction to restore cost centre, if any
415 restoreCurrentCostCentre cc_slot `thenFC` \ cc_restore ->
417 -- get the stack liveness for the info table (after the CC slot has
418 -- been freed - this is important).
419 buildContLivenessMask uniq `thenFC` \ liveness_mask ->
423 -- algebraic alts ...
424 (StgAlgAlts ty alts deflt) ->
426 -- bind the default binder (it covers all the alternatives)
427 (if (isDeadBinder bndr)
429 else bindNewToReg bndr node mkLFArgument) `thenC`
431 -- Generate sequel info for use downstream
432 -- At the moment, we only do it if the type is vector-returnable.
433 -- Reason: if not, then it costs extra to label the
434 -- alternatives, because we'd get return code like:
436 -- switch TagReg { 0 : JMP(alt_1); 1 : JMP(alt_2) ..etc }
438 -- which is worse than having the alt code in the switch statement
440 let tycon_info = getScrutineeTyCon ty
441 is_alg = maybeToBool tycon_info
442 Just spec_tycon = tycon_info
445 -- deal with the unboxed tuple case
446 if is_alg && isUnboxedTupleTyCon spec_tycon then
448 [alt] -> let lbl = mkReturnInfoLabel uniq in
449 cgUnboxedTupleAlt lbl cc_restore True alt
451 getSRTLabel `thenFC` \srt_label ->
452 absC (CRetDirect uniq abs_c (srt_label, srt)
453 liveness_mask) `thenC`
454 returnFC (CaseAlts (CLbl lbl RetRep) Nothing)
455 _ -> panic "cgEvalAlts: dodgy case of unboxed tuple type"
457 -- normal algebraic (or polymorphic) case alternatives
459 ret_conv | is_alg = ctrlReturnConvAlg spec_tycon
460 | otherwise = UnvectoredReturn 0
462 use_labelled_alts = case ret_conv of
463 VectoredReturn _ -> True
467 = if use_labelled_alts then
468 cgSemiTaggedAlts bndr alts deflt -- Just <something>
470 Nothing -- no semi-tagging info
473 cgAlgAlts GCMayHappen uniq cc_restore use_labelled_alts (not is_alg)
474 alts deflt True `thenFC` \ (tagged_alt_absCs, deflt_absC) ->
476 mkReturnVector uniq tagged_alt_absCs deflt_absC srt liveness_mask
477 ret_conv `thenFC` \ return_vec ->
479 returnFC (CaseAlts return_vec semi_tagged_stuff)
482 (StgPrimAlts ty alts deflt) ->
484 -- Generate the switch
485 getAbsC (cgPrimEvalAlts bndr ty alts deflt) `thenFC` \ abs_c ->
487 -- Generate the labelled block, starting with restore-cost-centre
488 getSRTLabel `thenFC` \srt_label ->
489 absC (CRetDirect uniq (cc_restore `mkAbsCStmts` abs_c)
490 (srt_label,srt) liveness_mask) `thenC`
492 -- Return an amode for the block
493 returnFC (CaseAlts (CLbl (mkReturnPtLabel uniq) RetRep) Nothing)
503 HWL comment on {\em GrAnSim\/} (adding GRAN_YIELDs for context switch): If
504 we do an inlining of the case no separate functions for returning are
505 created, so we don't have to generate a GRAN_YIELD in that case. This info
506 must be propagated to cgAlgAltRhs (where the GRAN_YIELD macro might be
507 emitted). Hence, the new Bool arg to cgAlgAltRhs.
509 First case: primitive op returns an unboxed tuple.
512 cgInlineAlts bndr (StgAlgAlts ty [alt@(con,args,use_mask,rhs)] StgNoDefault)
513 | isUnboxedTupleCon con
514 = -- no heap check, no yield, just get in there and do it.
515 mapFCs bindNewToTemp args `thenFC` \ _ ->
519 = panic "cgInlineAlts: single alternative, not an unboxed tuple"
529 cgInlineAlts bndr (StgAlgAlts ty [] (StgBindDefault rhs))
530 = bindNewToTemp bndr `thenFC` \amode ->
532 (tycon, _, _) = splitAlgTyConApp ty
533 closure_lbl = CTableEntry (CLbl (mkClosureTblLabel tycon) PtrRep) amode PtrRep
535 absC (CAssign amode closure_lbl) `thenC`
539 Second case: algebraic case, several alternatives.
540 Tag is held in a temporary.
543 cgInlineAlts bndr (StgAlgAlts ty alts deflt)
544 = cgAlgAlts NoGC uniq AbsCNop{-restore_cc-} False{-no semi-tagging-}
545 False{-not poly case-} alts deflt
546 False{-don't emit yield-} `thenFC` \ (tagged_alts, deflt_c) ->
549 absC (mkAlgAltsCSwitch tag_amode tagged_alts deflt_c)
551 -- A temporary variable to hold the tag; this is unaffected by GC because
552 -- the heap-checks in the branches occur after the switch
553 tag_amode = CTemp uniq IntRep
554 uniq = getUnique bndr
557 Third (real) case: primitive result type.
560 cgInlineAlts bndr (StgPrimAlts ty alts deflt)
561 = cgPrimInlineAlts bndr ty alts deflt
565 %************************************************************************
567 \subsection[CgCase-alg-alts]{Algebraic alternatives}
569 %************************************************************************
571 In @cgAlgAlts@, none of the binders in the alternatives are
572 assumed to be yet bound.
574 HWL comment on {\em GrAnSim\/} (adding GRAN_YIELDs for context switch): The
575 last arg of cgAlgAlts indicates if we want a context switch at the
576 beginning of each alternative. Normally we want that. The only exception
577 are inlined alternatives.
582 -> AbstractC -- Restore-cost-centre instruction
583 -> Bool -- True <=> branches must be labelled
584 -> Bool -- True <=> polymorphic case
585 -> [(DataCon, [Id], [Bool], StgExpr)] -- The alternatives
586 -> StgCaseDefault -- The default
587 -> Bool -- Context switch at alts?
588 -> FCode ([(ConTag, AbstractC)], -- The branches
589 AbstractC -- The default case
592 cgAlgAlts gc_flag uniq restore_cc must_label_branches is_fun alts deflt
593 emit_yield{-should a yield macro be emitted?-}
595 = forkAlts (map (cgAlgAlt gc_flag uniq restore_cc must_label_branches emit_yield) alts)
596 (cgAlgDefault gc_flag is_fun uniq restore_cc must_label_branches deflt emit_yield)
600 cgAlgDefault :: GCFlag
601 -> Bool -- could be a function-typed result?
602 -> Unique -> AbstractC -> Bool -- turgid state...
603 -> StgCaseDefault -- input
605 -> FCode AbstractC -- output
607 cgAlgDefault gc_flag is_fun uniq restore_cc must_label_branch StgNoDefault _
610 cgAlgDefault gc_flag is_fun uniq restore_cc must_label_branch
612 emit_yield{-should a yield macro be emitted?-}
614 = -- We have arranged that Node points to the thing
615 getAbsC (absC restore_cc `thenC`
616 (if opt_GranMacros && emit_yield
617 then yield [node] False
618 else absC AbsCNop) `thenC`
619 possibleHeapCheck gc_flag is_fun [node] [] Nothing (cgExpr rhs)
620 -- Node is live, but doesn't need to point at the thing itself;
621 -- it's ok for Node to point to an indirection or FETCH_ME
622 -- Hence no need to re-enter Node.
623 ) `thenFC` \ abs_c ->
626 final_abs_c | must_label_branch = CCodeBlock lbl abs_c
631 lbl = mkDefaultLabel uniq
633 -- HWL comment on GrAnSim: GRAN_YIELDs needed; emitted in cgAlgAltRhs
636 -> Unique -> AbstractC -> Bool -- turgid state
637 -> Bool -- Context switch at alts?
638 -> (DataCon, [Id], [Bool], StgExpr)
639 -> FCode (ConTag, AbstractC)
641 cgAlgAlt gc_flag uniq restore_cc must_label_branch
642 emit_yield{-should a yield macro be emitted?-}
643 (con, args, use_mask, rhs)
644 = getAbsC (absC restore_cc `thenC`
645 (if opt_GranMacros && emit_yield
646 then yield [node] True -- XXX live regs wrong
647 else absC AbsCNop) `thenC`
649 NoGC -> mapFCs bindNewToTemp args `thenFC` \_ -> nopC
650 GCMayHappen -> bindConArgs con args
652 possibleHeapCheck gc_flag False [node] [] Nothing (
654 ) `thenFC` \ abs_c ->
656 final_abs_c | must_label_branch = CCodeBlock lbl abs_c
659 returnFC (tag, final_abs_c)
662 lbl = mkAltLabel uniq tag
665 :: CLabel -- label of the alternative
667 -> Bool -- ctxt switch
668 -> (DataCon, [Id], [Bool], StgExpr) -- alternative
671 cgUnboxedTupleAlt lbl restore_cc emit_yield (con,args,use_mask,rhs)
673 absC restore_cc `thenC`
675 bindUnboxedTupleComponents args
676 `thenFC` \ (live_regs,tags,stack_res) ->
677 (if opt_GranMacros && emit_yield
678 then yield live_regs True -- XXX live regs wrong?
679 else absC AbsCNop) `thenC`
681 -- ToDo: could maybe use Nothing here if stack_res is False
682 -- since the heap-check can just return to the top of the
687 -- free up stack slots containing tags,
688 freeStackSlots (map fst tags) `thenC`
690 -- generate a heap check if necessary
691 possibleHeapCheck GCMayHappen False live_regs tags ret_addr (
693 -- and finally the code for the alternative
698 %************************************************************************
700 \subsection[CgCase-semi-tagged-alts]{The code to deal with sem-tagging}
702 %************************************************************************
704 Turgid-but-non-monadic code to conjure up the required info from
705 algebraic case alternatives for semi-tagging.
708 cgSemiTaggedAlts :: Id
709 -> [(DataCon, [Id], [Bool], StgExpr)]
710 -> GenStgCaseDefault Id Id
713 cgSemiTaggedAlts binder alts deflt
714 = Just (map st_alt alts, st_deflt deflt)
716 uniq = getUnique binder
718 st_deflt StgNoDefault = Nothing
720 st_deflt (StgBindDefault _)
722 (CCallProfCtrMacro SLIT("RET_SEMI_BY_DEFAULT") [], -- ToDo: monadise?
726 st_alt (con, args, use_mask, _)
727 = -- Ha! Nothing to do; Node already points to the thing
729 (CCallProfCtrMacro SLIT("RET_SEMI_IN_HEAP") -- ToDo: monadise?
730 [mkIntCLit (length args)], -- how big the thing in the heap is
734 con_tag = dataConTag con
735 join_label = mkAltLabel uniq con_tag
738 %************************************************************************
740 \subsection[CgCase-prim-alts]{Primitive alternatives}
742 %************************************************************************
744 @cgPrimEvalAlts@ and @cgPrimInlineAlts@ generate suitable @CSwitch@es
745 for dealing with the alternatives of a primitive @case@, given an
746 addressing mode for the thing to scrutinise. It also keeps track of
747 the maximum stack depth encountered down any branch.
749 As usual, no binders in the alternatives are yet bound.
752 cgPrimInlineAlts bndr ty alts deflt
753 = cgPrimAltsWithDefault bndr NoGC (CTemp uniq kind) alts deflt []
755 uniq = getUnique bndr
756 kind = typePrimRep ty
758 cgPrimEvalAlts bndr ty alts deflt
759 = cgPrimAltsWithDefault bndr GCMayHappen (CReg reg) alts deflt [reg]
761 reg = dataReturnConvPrim kind
762 kind = typePrimRep ty
764 cgPrimAltsWithDefault bndr gc_flag scrutinee alts deflt regs
765 = -- first bind the default if necessary
766 (if isDeadBinder bndr
768 else bindNewPrimToAmode bndr scrutinee) `thenC`
769 cgPrimAlts gc_flag scrutinee alts deflt regs
771 cgPrimAlts gc_flag scrutinee alts deflt regs
772 = forkAlts (map (cgPrimAlt gc_flag regs) alts)
773 (cgPrimDefault gc_flag regs deflt)
774 `thenFC` \ (alt_absCs, deflt_absC) ->
776 absC (CSwitch scrutinee alt_absCs deflt_absC)
777 -- CSwitch does sensible things with one or zero alternatives
781 -> [MagicId] -- live registers
782 -> (Literal, StgExpr) -- The alternative
783 -> FCode (Literal, AbstractC) -- Its compiled form
785 cgPrimAlt gc_flag regs (lit, rhs)
786 = getAbsC rhs_code `thenFC` \ absC ->
789 rhs_code = possibleHeapCheck gc_flag False regs [] Nothing (cgExpr rhs)
791 cgPrimDefault :: GCFlag
792 -> [MagicId] -- live registers
796 cgPrimDefault gc_flag regs StgNoDefault
797 = panic "cgPrimDefault: No default in prim case"
799 cgPrimDefault gc_flag regs (StgBindDefault rhs)
800 = getAbsC (possibleHeapCheck gc_flag False regs [] Nothing (cgExpr rhs))
804 %************************************************************************
806 \subsection[CgCase-tidy]{Code for tidying up prior to an eval}
808 %************************************************************************
811 saveVolatileVarsAndRegs
812 :: StgLiveVars -- Vars which should be made safe
813 -> FCode (AbstractC, -- Assignments to do the saves
814 EndOfBlockInfo, -- sequel for the alts
815 Maybe VirtualSpOffset) -- Slot for current cost centre
818 saveVolatileVarsAndRegs vars
819 = saveVolatileVars vars `thenFC` \ var_saves ->
820 saveCurrentCostCentre `thenFC` \ (maybe_cc_slot, cc_save) ->
821 getEndOfBlockInfo `thenFC` \ eob_info ->
822 returnFC (mkAbstractCs [var_saves, cc_save],
827 saveVolatileVars :: StgLiveVars -- Vars which should be made safe
828 -> FCode AbstractC -- Assignments to to the saves
830 saveVolatileVars vars
831 = save_em (varSetElems vars)
833 save_em [] = returnFC AbsCNop
836 = getCAddrModeIfVolatile var `thenFC` \ v ->
838 Nothing -> save_em vars -- Non-volatile, so carry on
841 Just vol_amode -> -- Aha! It's volatile
842 save_var var vol_amode `thenFC` \ abs_c ->
843 save_em vars `thenFC` \ abs_cs ->
844 returnFC (abs_c `mkAbsCStmts` abs_cs)
846 save_var var vol_amode
847 = allocPrimStack (getPrimRepSize kind) `thenFC` \ slot ->
848 rebindToStack var slot `thenC`
849 getSpRelOffset slot `thenFC` \ sp_rel ->
850 returnFC (CAssign (CVal sp_rel kind) vol_amode)
852 kind = getAmodeRep vol_amode
855 ---------------------------------------------------------------------------
857 When we save the current cost centre (which is done for lexical
858 scoping), we allocate a free stack location, and return (a)~the
859 virtual offset of the location, to pass on to the alternatives, and
860 (b)~the assignment to do the save (just as for @saveVolatileVars@).
863 saveCurrentCostCentre ::
864 FCode (Maybe VirtualSpOffset, -- Where we decide to store it
865 AbstractC) -- Assignment to save it
867 saveCurrentCostCentre
868 = if not opt_SccProfilingOn then
869 returnFC (Nothing, AbsCNop)
871 allocPrimStack (getPrimRepSize CostCentreRep) `thenFC` \ slot ->
872 getSpRelOffset slot `thenFC` \ sp_rel ->
874 CAssign (CVal sp_rel CostCentreRep) (CReg CurCostCentre))
876 restoreCurrentCostCentre :: Maybe VirtualSpOffset -> FCode AbstractC
878 restoreCurrentCostCentre Nothing
880 restoreCurrentCostCentre (Just slot)
881 = getSpRelOffset slot `thenFC` \ sp_rel ->
882 freeStackSlots [slot] `thenC`
883 returnFC (CCallProfCCMacro SLIT("RESTORE_CCCS") [CVal sp_rel CostCentreRep])
884 -- we use the RESTORE_CCCS macro, rather than just
885 -- assigning into CurCostCentre, in case RESTORE_CCC
886 -- has some sanity-checking in it.
889 %************************************************************************
891 \subsection[CgCase-return-vec]{Building a return vector}
893 %************************************************************************
895 Build a return vector, and return a suitable label addressing
899 mkReturnVector :: Unique
900 -> [(ConTag, AbstractC)] -- Branch codes
901 -> AbstractC -- Default case
902 -> SRT -- continuation's SRT
903 -> Liveness -- stack liveness
904 -> CtrlReturnConvention
907 mkReturnVector uniq tagged_alt_absCs deflt_absC srt liveness ret_conv
908 = getSRTLabel `thenFC` \srt_label ->
910 srt_info = (srt_label, srt)
912 (return_vec_amode, vtbl_body) = case ret_conv of {
914 -- might be a polymorphic case...
915 UnvectoredReturn 0 ->
916 ASSERT(null tagged_alt_absCs)
917 (CLbl ret_label RetRep,
918 absC (CRetDirect uniq deflt_absC (srt_label, srt) liveness));
920 UnvectoredReturn n ->
921 -- find the tag explicitly rather than using tag_reg for now.
922 -- on architectures with lots of regs the tag will be loaded
923 -- into tag_reg by the code doing the returning.
925 tag = CMacroExpr WordRep GET_TAG [CVal (nodeRel 0) DataPtrRep]
927 (CLbl ret_label RetRep,
928 absC (CRetDirect uniq
929 (mkAlgAltsCSwitch tag tagged_alt_absCs deflt_absC)
933 VectoredReturn table_size ->
935 (vector_table, alts_absC) =
936 unzip (map mk_vector_entry [fIRST_TAG .. (table_size+fIRST_TAG-1)])
938 ret_vector = CRetVector vtbl_label
940 (srt_label, srt) liveness
942 (CLbl vtbl_label DataPtrRep,
943 -- alts come first, because we don't want to declare all the symbols
944 absC (mkAbstractCs (mkAbstractCs alts_absC : [deflt_absC,ret_vector]))
949 returnFC return_vec_amode
953 vtbl_label = mkVecTblLabel uniq
954 ret_label = mkReturnInfoLabel uniq
957 case nonemptyAbsC deflt_absC of
958 -- the simplifier might have eliminated a case
959 Nothing -> CLbl mkErrorStdEntryLabel CodePtrRep
960 Just absC@(CCodeBlock lbl _) -> CLbl lbl CodePtrRep
962 mk_vector_entry :: ConTag -> (CAddrMode, AbstractC)
964 = case [ absC | (t, absC) <- tagged_alt_absCs, t == tag ] of
965 [] -> (deflt_lbl, AbsCNop)
966 [absC@(CCodeBlock lbl _)] -> (CLbl lbl CodePtrRep,absC)
967 _ -> panic "mkReturnVector: too many"
970 %************************************************************************
972 \subsection[CgCase-utils]{Utilities for handling case expressions}
974 %************************************************************************
976 @possibleHeapCheck@ tests a flag passed in to decide whether to do a
977 heap check or not. These heap checks are always in a case
978 alternative, so we use altHeapCheck.
983 -> Bool -- True <=> algebraic case
984 -> [MagicId] -- live registers
985 -> [(VirtualSpOffset,Int)] -- stack slots to tag
986 -> Maybe CLabel -- return address
987 -> Code -- continuation
990 possibleHeapCheck GCMayHappen is_alg regs tags lbl code
991 = altHeapCheck is_alg regs tags AbsCNop lbl code
992 possibleHeapCheck NoGC _ _ tags lbl code
996 splitTyConAppThroughNewTypes is like splitAlgTyConApp_maybe except
997 that it looks through newtypes in addition to synonyms. It's
998 useful in the back end where we're not interested in newtypes
1001 Sometimes, we've thrown away the constructors during pruning in the
1002 renamer. In these cases, we emit a warning and fall back to using a
1003 SEQ_FRAME to evaluate the case scrutinee.
1006 getScrutineeTyCon :: Type -> Maybe TyCon
1007 getScrutineeTyCon ty =
1008 case (splitAlgTyConAppThroughNewTypes ty) of
1011 if not (isAlgTyCon tc) then Just tc else
1012 case (tyConFamilySize tc) of
1013 0 -> pprTrace "Warning" (hcat [
1014 text "constructors for ",
1016 text " not available.\n\tUse -fno-prune-tydecls to fix."
1020 splitAlgTyConAppThroughNewTypes :: Type -> Maybe (TyCon, [Type])
1021 splitAlgTyConAppThroughNewTypes ty
1022 = case splitAlgTyConApp_maybe ty of
1023 Just (tc, tys, cons)
1024 | isNewTyCon tc -> splitAlgTyConAppThroughNewTypes ty
1025 | otherwise -> Just (tc, tys)
1027 ([ty], _) = splitFunTys (applyTys (dataConType (head cons)) tys)