2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 % $Id: CgCase.lhs,v 1.27 1999/04/27 12:34:52 simonm Exp $
6 %********************************************************
8 \section[CgCase]{Converting @StgCase@ expressions}
10 %********************************************************
13 module CgCase ( cgCase, saveVolatileVarsAndRegs,
14 restoreCurrentCostCentre, freeCostCentreSlot,
15 splitTyConAppThroughNewTypes ) where
17 #include "HsVersions.h"
19 import {-# SOURCE #-} CgExpr ( cgExpr )
25 import AbsCUtils ( mkAbstractCs, mkAbsCStmts, mkAlgAltsCSwitch,
26 getAmodeRep, nonemptyAbsC
28 import CoreSyn ( isDeadBinder )
29 import CgUpdate ( reserveSeqFrame )
30 import CgBindery ( getVolatileRegs, getArgAmodes, getArgAmode,
31 bindNewToReg, bindNewToTemp,
33 rebindToStack, getCAddrMode,
34 getCAddrModeAndInfo, getCAddrModeIfVolatile,
35 buildContLivenessMask, nukeDeadBindings,
37 import CgCon ( bindConArgs, bindUnboxedTupleComponents )
38 import CgHeapery ( altHeapCheck, yield )
39 import CgRetConv ( dataReturnConvPrim, ctrlReturnConvAlg,
40 CtrlReturnConvention(..)
42 import CgStackery ( allocPrimStack, allocStackTop,
43 deAllocStackTop, freeStackSlots
45 import CgTailCall ( tailCallFun )
46 import CgUsages ( getSpRelOffset, getRealSp )
47 import CLabel ( CLabel, mkVecTblLabel, mkReturnPtLabel,
48 mkDefaultLabel, mkAltLabel, mkReturnInfoLabel,
49 mkErrorStdEntryLabel, mkClosureTblLabel
51 import ClosureInfo ( mkLFArgument )
52 import CmdLineOpts ( opt_SccProfilingOn, opt_GranMacros )
53 import CostCentre ( CostCentre )
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,
67 splitFunTys, applyTys )
68 import Unique ( Unique, Uniquable(..), mkBuiltinUnique )
69 import Maybes ( maybeToBool )
76 = GCMayHappen -- The scrutinee may involve GC, so everything must be
77 -- tidy before the code for the scrutinee.
79 | NoGC -- The scrutinee is a primitive value, or a call to a
80 -- primitive op which does no GC. Hence the case can
81 -- be done inline, without tidying up first.
84 It is quite interesting to decide whether to put a heap-check
85 at the start of each alternative. Of course we certainly have
86 to do so if the case forces an evaluation, or if there is a primitive
87 op which can trigger GC.
89 A more interesting situation is this:
96 default -> !C!; ...C...
99 where \tr{!x!} indicates a possible heap-check point. The heap checks
100 in the alternatives {\em can} be omitted, in which case the topmost
101 heapcheck will take their worst case into account.
103 In favour of omitting \tr{!B!}, \tr{!C!}:
105 - {\em May} save a heap overflow test,
106 if ...A... allocates anything. The other advantage
107 of this is that we can use relative addressing
108 from a single Hp to get at all the closures so allocated.
110 - No need to save volatile vars etc across the case
114 - May do more allocation than reqd. This sometimes bites us
115 badly. For example, nfib (ha!) allocates about 30\% more space if the
116 worst-casing is done, because many many calls to nfib are leaf calls
117 which don't need to allocate anything.
119 This never hurts us if there is only one alternative.
131 Special case #1: PrimOps returning enumeration types.
133 For enumeration types, we invent a temporary (builtin-unique 1) to
134 hold the tag, and cross our fingers that this doesn't clash with
135 anything else. Builtin-unique 0 is used for a similar reason when
136 compiling enumerated-type primops in CgExpr.lhs. We can't use the
137 unique from the case binder, because this is used to hold the actual
138 closure (when the case binder is live, that is).
140 There is an extra special case for
145 which generates no code for the primop, unless x is used in the
146 alternatives (in which case we lookup the tag in the relevant closure
147 table to get the closure).
150 cgCase (StgCon (PrimOp op) args res_ty)
151 live_in_whole_case live_in_alts bndr srt (StgAlgAlts ty alts deflt)
152 | isEnumerationTyCon tycon
153 = getArgAmodes args `thenFC` \ arg_amodes ->
155 let tag_amode = case op of
156 TagToEnumOp -> only arg_amodes
157 _ -> CTemp (mkBuiltinUnique 1) IntRep
159 closure = CTableEntry (CLbl (mkClosureTblLabel tycon) PtrRep) tag_amode PtrRep
163 TagToEnumOp -> nopC; -- no code!
165 _ -> -- Perform the operation
166 getVolatileRegs live_in_alts `thenFC` \ vol_regs ->
168 absC (COpStmt [tag_amode] op
169 arg_amodes -- note: no liveness arg
173 -- bind the default binder if necessary
174 (if (isDeadBinder bndr)
176 else bindNewToTemp bndr `thenFC` \ bndr_amode ->
177 absC (CAssign bndr_amode closure))
181 cgAlgAlts NoGC uniq Nothing{-cc_slot-} False{-no semi-tagging-}
182 False{-not poly case-} alts deflt
183 False{-don't emit yield-} `thenFC` \ (tagged_alts, deflt_c) ->
186 absC (mkAlgAltsCSwitch tag_amode tagged_alts deflt_c)
189 (Just (tycon,_)) = splitTyConApp_maybe res_ty
190 uniq = getUnique bndr
193 Special case #2: inline PrimOps.
196 cgCase (StgCon (PrimOp op) args res_ty)
197 live_in_whole_case live_in_alts bndr srt alts
198 | not (primOpOutOfLine op)
200 -- Get amodes for the arguments and results
201 getArgAmodes args `thenFC` \ arg_amodes ->
203 result_amodes = getPrimAppResultAmodes (getUnique bndr) alts
205 -- Perform the operation
206 getVolatileRegs live_in_alts `thenFC` \ vol_regs ->
208 absC (COpStmt result_amodes op
209 arg_amodes -- note: no liveness arg
212 -- Scrutinise the result
213 cgInlineAlts bndr alts
216 TODO: Case-of-case of primop can probably be done inline too (but
217 maybe better to translate it out beforehand). See
218 ghc/lib/misc/PackedString.lhs for examples where this crops up (with
221 Another special case: scrutinising a primitive-typed variable. No
222 evaluation required. We don't save volatile variables, nor do we do a
223 heap-check in the alternatives. Instead, the heap usage of the
224 alternatives is worst-cased and passed upstream. This can result in
225 allocating more heap than strictly necessary, but it will sometimes
226 eliminate a heap check altogether.
229 cgCase (StgApp v []) live_in_whole_case live_in_alts bndr srt
230 (StgPrimAlts ty alts deflt)
233 getCAddrMode v `thenFC` \amode ->
236 Careful! we can't just bind the default binder to the same thing
237 as the scrutinee, since it might be a stack location, and having
238 two bindings pointing at the same stack locn doesn't work (it
239 confuses nukeDeadBindings). Hence, use a new temp.
241 (if (isDeadBinder bndr)
243 else bindNewToTemp bndr `thenFC` \deflt_amode ->
244 absC (CAssign deflt_amode amode)) `thenC`
246 cgPrimAlts NoGC amode alts deflt []
249 Special case: scrutinising a non-primitive variable.
250 This can be done a little better than the general case, because
251 we can reuse/trim the stack slot holding the variable (if it is in one).
254 cgCase (StgApp fun args)
255 live_in_whole_case live_in_alts bndr srt alts@(StgAlgAlts ty _ _)
257 getCAddrModeAndInfo fun `thenFC` \ (fun_amode, lf_info) ->
258 getArgAmodes args `thenFC` \ arg_amodes ->
260 -- Squish the environment
261 nukeDeadBindings live_in_alts `thenC`
262 saveVolatileVarsAndRegs live_in_alts
263 `thenFC` \ (save_assts, alts_eob_info, maybe_cc_slot) ->
265 allocStackTop retPrimRepSize `thenFC` \_ ->
267 forkEval alts_eob_info nopC (
268 deAllocStackTop retPrimRepSize `thenFC` \_ ->
269 cgEvalAlts maybe_cc_slot bndr srt alts)
270 `thenFC` \ scrut_eob_info ->
272 let real_scrut_eob_info =
274 then reserveSeqFrame scrut_eob_info
278 setEndOfBlockInfo real_scrut_eob_info (
279 tailCallFun fun fun_amode lf_info arg_amodes save_assts
283 not_con_ty = case (getScrutineeTyCon ty) of
288 Note about return addresses: we *always* push a return address, even
289 if because of an optimisation we end up jumping direct to the return
290 code (not through the address itself). The alternatives always assume
291 that the return address is on the stack. The return address is
292 required in case the alternative performs a heap check, since it
293 encodes the liveness of the slots in the activation record.
295 On entry to the case alternative, we can re-use the slot containing
296 the return address immediately after the heap check. That's what the
297 deAllocStackTop call is doing above.
299 Finally, here is the general case.
302 cgCase expr live_in_whole_case live_in_alts bndr srt alts
303 = -- Figure out what volatile variables to save
304 nukeDeadBindings live_in_whole_case `thenC`
306 saveVolatileVarsAndRegs live_in_alts
307 `thenFC` \ (save_assts, alts_eob_info, maybe_cc_slot) ->
309 -- Save those variables right now!
310 absC save_assts `thenC`
312 -- generate code for the alts
313 forkEval alts_eob_info
315 nukeDeadBindings live_in_alts `thenC`
316 allocStackTop retPrimRepSize -- space for retn address
319 (deAllocStackTop retPrimRepSize `thenFC` \_ ->
320 cgEvalAlts maybe_cc_slot bndr srt alts) `thenFC` \ scrut_eob_info ->
322 let real_scrut_eob_info =
324 then reserveSeqFrame scrut_eob_info
328 setEndOfBlockInfo real_scrut_eob_info (cgExpr expr)
331 not_con_ty = case (getScrutineeTyCon (alts_ty alts)) of
336 There's a lot of machinery going on behind the scenes to manage the
337 stack pointer here. forkEval takes the virtual Sp and free list from
338 the first argument, and turns that into the *real* Sp for the second
339 argument. It also uses this virtual Sp as the args-Sp in the EOB info
340 returned, so that the scrutinee will trim the real Sp back to the
341 right place before doing whatever it does.
342 --SDM (who just spent an hour figuring this out, and didn't want to
345 Why don't we push the return address just before evaluating the
346 scrutinee? Because the slot reserved for the return address might
347 contain something useful, so we wait until performing a tail call or
348 return before pushing the return address (see
349 CgTailCall.pushReturnAddress).
351 This also means that the environment doesn't need to know about the
352 free stack slot for the return address (for generating bitmaps),
353 because we don't reserve it until just before the eval.
355 TODO!! Problem: however, we have to save the current cost centre
356 stack somewhere, because at the eval point the current CCS might be
357 different. So we pick a free stack slot and save CCCS in it. The
358 problem with this is that this slot isn't recorded as free/unboxed in
359 the environment, so a case expression in the scrutinee will have the
360 wrong bitmap attached. Fortunately we don't ever seem to see
361 case-of-case at the back end. One solution might be to shift the
362 saved CCS to the correct place in the activation record just before
366 (one consequence of the above is that activation records on the stack
367 don't follow the layout of closures when we're profiling. The CCS
368 could be anywhere within the record).
371 alts_ty (StgAlgAlts ty _ _) = ty
372 alts_ty (StgPrimAlts ty _ _) = ty
375 %************************************************************************
377 \subsection[CgCase-primops]{Primitive applications}
379 %************************************************************************
381 Get result amodes for a primitive operation, in the case wher GC can't happen.
382 The amodes are returned in canonical order, ready for the prim-op!
384 Alg case: temporaries named as in the alternatives,
385 plus (CTemp u) for the tag (if needed)
388 This is all disgusting, because these amodes must be consistent with those
389 invented by CgAlgAlts.
392 getPrimAppResultAmodes
397 getPrimAppResultAmodes uniq (StgAlgAlts ty alts some_default)
399 | isUnboxedTupleTyCon tycon =
401 [(con, args, use_mask, rhs)] ->
402 [ CTemp (getUnique arg) (idPrimRep arg) | arg <- args ]
403 _ -> panic "getPrimAppResultAmodes: case of unboxed tuple has multiple branches"
405 | otherwise = panic ("getPrimAppResultAmodes: case of primop has strange type: " ++ showSDoc (ppr ty))
407 where (tycon, _, _) = splitAlgTyConApp ty
409 -- The situation is simpler for primitive results, because there is only
412 getPrimAppResultAmodes uniq (StgPrimAlts ty _ _)
413 = [CTemp uniq (typePrimRep ty)]
417 %************************************************************************
419 \subsection[CgCase-alts]{Alternatives}
421 %************************************************************************
423 @cgEvalAlts@ returns an addressing mode for a continuation for the
424 alternatives of a @case@, used in a context when there
425 is some evaluation to be done.
428 cgEvalAlts :: Maybe VirtualSpOffset -- Offset of cost-centre to be restored, if any
430 -> SRT -- SRT for the continuation
432 -> FCode Sequel -- Any addr modes inside are guaranteed
433 -- to be a label so that we can duplicate it
434 -- without risk of duplicating code
436 cgEvalAlts cc_slot bndr srt alts
438 let uniq = getUnique bndr in
440 -- get the stack liveness for the info table (after the CC slot has
441 -- been freed - this is important).
442 freeCostCentreSlot cc_slot `thenC`
443 buildContLivenessMask uniq `thenFC` \ liveness_mask ->
447 -- algebraic alts ...
448 (StgAlgAlts ty alts deflt) ->
450 -- bind the default binder (it covers all the alternatives)
451 (if (isDeadBinder bndr)
453 else bindNewToReg bndr node mkLFArgument) `thenC`
455 -- Generate sequel info for use downstream
456 -- At the moment, we only do it if the type is vector-returnable.
457 -- Reason: if not, then it costs extra to label the
458 -- alternatives, because we'd get return code like:
460 -- switch TagReg { 0 : JMP(alt_1); 1 : JMP(alt_2) ..etc }
462 -- which is worse than having the alt code in the switch statement
464 let tycon_info = getScrutineeTyCon ty
465 is_alg = maybeToBool tycon_info
466 Just spec_tycon = tycon_info
469 -- deal with the unboxed tuple case
470 if is_alg && isUnboxedTupleTyCon spec_tycon then
472 [alt] -> let lbl = mkReturnInfoLabel uniq in
473 cgUnboxedTupleAlt lbl cc_slot True alt
475 getSRTLabel `thenFC` \srt_label ->
476 absC (CRetDirect uniq abs_c (srt_label, srt)
477 liveness_mask) `thenC`
478 returnFC (CaseAlts (CLbl lbl RetRep) Nothing)
479 _ -> panic "cgEvalAlts: dodgy case of unboxed tuple type"
481 -- normal algebraic (or polymorphic) case alternatives
483 ret_conv | is_alg = ctrlReturnConvAlg spec_tycon
484 | otherwise = UnvectoredReturn 0
486 use_labelled_alts = case ret_conv of
487 VectoredReturn _ -> True
491 = if use_labelled_alts then
492 cgSemiTaggedAlts bndr alts deflt -- Just <something>
494 Nothing -- no semi-tagging info
497 cgAlgAlts GCMayHappen uniq cc_slot use_labelled_alts (not is_alg)
498 alts deflt True `thenFC` \ (tagged_alt_absCs, deflt_absC) ->
500 mkReturnVector uniq tagged_alt_absCs deflt_absC srt liveness_mask
501 ret_conv `thenFC` \ return_vec ->
503 returnFC (CaseAlts return_vec semi_tagged_stuff)
506 (StgPrimAlts ty alts deflt) ->
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 restoreCurrentCostCentre cc_slot `thenFC` \ cc_restore ->
514 absC (CRetDirect uniq (cc_restore `mkAbsCStmts` abs_c)
515 (srt_label,srt) liveness_mask) `thenC`
517 -- Return an amode for the block
518 returnFC (CaseAlts (CLbl (mkReturnPtLabel uniq) RetRep) Nothing)
528 HWL comment on {\em GrAnSim\/} (adding GRAN_YIELDs for context switch): If
529 we do an inlining of the case no separate functions for returning are
530 created, so we don't have to generate a GRAN_YIELD in that case. This info
531 must be propagated to cgAlgAltRhs (where the GRAN_YIELD macro might be
532 emitted). Hence, the new Bool arg to cgAlgAltRhs.
534 First case: primitive op returns an unboxed tuple.
537 cgInlineAlts bndr (StgAlgAlts ty [alt@(con,args,use_mask,rhs)] StgNoDefault)
538 | isUnboxedTupleCon con
539 = -- no heap check, no yield, just get in there and do it.
540 mapFCs bindNewToTemp args `thenFC` \ _ ->
544 = panic "cgInlineAlts: single alternative, not an unboxed tuple"
547 Third (real) case: primitive result type.
550 cgInlineAlts bndr (StgPrimAlts ty alts deflt)
551 = cgPrimInlineAlts bndr ty alts deflt
554 %************************************************************************
556 \subsection[CgCase-alg-alts]{Algebraic alternatives}
558 %************************************************************************
560 In @cgAlgAlts@, none of the binders in the alternatives are
561 assumed to be yet bound.
563 HWL comment on {\em GrAnSim\/} (adding GRAN_YIELDs for context switch): The
564 last arg of cgAlgAlts indicates if we want a context switch at the
565 beginning of each alternative. Normally we want that. The only exception
566 are inlined alternatives.
571 -> Maybe VirtualSpOffset
572 -> Bool -- True <=> branches must be labelled
573 -> Bool -- True <=> polymorphic case
574 -> [(DataCon, [Id], [Bool], StgExpr)] -- The alternatives
575 -> StgCaseDefault -- The default
576 -> Bool -- Context switch at alts?
577 -> FCode ([(ConTag, AbstractC)], -- The branches
578 AbstractC -- The default case
581 cgAlgAlts gc_flag uniq restore_cc must_label_branches is_fun alts deflt
582 emit_yield{-should a yield macro be emitted?-}
584 = forkAlts (map (cgAlgAlt gc_flag uniq restore_cc must_label_branches emit_yield) alts)
585 (cgAlgDefault gc_flag is_fun uniq restore_cc must_label_branches deflt emit_yield)
589 cgAlgDefault :: GCFlag
590 -> Bool -- could be a function-typed result?
591 -> Unique -> Maybe VirtualSpOffset -> Bool -- turgid state...
592 -> StgCaseDefault -- input
594 -> FCode AbstractC -- output
596 cgAlgDefault gc_flag is_fun uniq cc_slot must_label_branch StgNoDefault _
599 cgAlgDefault gc_flag is_fun uniq cc_slot must_label_branch
601 emit_yield{-should a yield macro be emitted?-}
603 = -- We have arranged that Node points to the thing
604 restoreCurrentCostCentre cc_slot `thenFC` \restore_cc ->
605 getAbsC (absC restore_cc `thenC`
606 (if opt_GranMacros && emit_yield
607 then yield [node] False
608 else absC AbsCNop) `thenC`
609 possibleHeapCheck gc_flag is_fun [node] [] Nothing (cgExpr rhs)
610 -- Node is live, but doesn't need to point at the thing itself;
611 -- it's ok for Node to point to an indirection or FETCH_ME
612 -- Hence no need to re-enter Node.
613 ) `thenFC` \ abs_c ->
616 final_abs_c | must_label_branch = CCodeBlock lbl abs_c
621 lbl = mkDefaultLabel uniq
623 -- HWL comment on GrAnSim: GRAN_YIELDs needed; emitted in cgAlgAltRhs
626 -> Unique -> Maybe VirtualSpOffset -> Bool -- turgid state
627 -> Bool -- Context switch at alts?
628 -> (DataCon, [Id], [Bool], StgExpr)
629 -> FCode (ConTag, AbstractC)
631 cgAlgAlt gc_flag uniq cc_slot must_label_branch
632 emit_yield{-should a yield macro be emitted?-}
633 (con, args, use_mask, rhs)
635 restoreCurrentCostCentre cc_slot `thenFC` \restore_cc ->
636 getAbsC (absC restore_cc `thenC`
637 (if opt_GranMacros && emit_yield
638 then yield [node] True -- XXX live regs wrong
639 else absC AbsCNop) `thenC`
641 NoGC -> mapFCs bindNewToTemp args `thenFC` \_ -> nopC
642 GCMayHappen -> bindConArgs con args
644 possibleHeapCheck gc_flag False [node] [] Nothing (
646 ) `thenFC` \ abs_c ->
648 final_abs_c | must_label_branch = CCodeBlock lbl abs_c
651 returnFC (tag, final_abs_c)
654 lbl = mkAltLabel uniq tag
657 :: CLabel -- label of the alternative
658 -> Maybe VirtualSpOffset -- Restore cost centre
659 -> Bool -- ctxt switch
660 -> (DataCon, [Id], [Bool], StgExpr) -- alternative
663 cgUnboxedTupleAlt lbl cc_slot emit_yield (con,args,use_mask,rhs)
665 bindUnboxedTupleComponents args
666 `thenFC` \ (live_regs,tags,stack_res) ->
668 restoreCurrentCostCentre cc_slot `thenFC` \restore_cc ->
669 absC restore_cc `thenC`
671 (if opt_GranMacros && emit_yield
672 then yield live_regs True -- XXX live regs wrong?
673 else absC AbsCNop) `thenC`
675 -- ToDo: could maybe use Nothing here if stack_res is False
676 -- since the heap-check can just return to the top of the
681 -- free up stack slots containing tags,
682 freeStackSlots (map fst tags) `thenC`
684 -- generate a heap check if necessary
685 possibleHeapCheck GCMayHappen False live_regs tags ret_addr (
687 -- and finally the code for the alternative
692 %************************************************************************
694 \subsection[CgCase-semi-tagged-alts]{The code to deal with sem-tagging}
696 %************************************************************************
698 Turgid-but-non-monadic code to conjure up the required info from
699 algebraic case alternatives for semi-tagging.
702 cgSemiTaggedAlts :: Id
703 -> [(DataCon, [Id], [Bool], StgExpr)]
704 -> GenStgCaseDefault Id Id
707 cgSemiTaggedAlts binder alts deflt
708 = Just (map st_alt alts, st_deflt deflt)
710 uniq = getUnique binder
712 st_deflt StgNoDefault = Nothing
714 st_deflt (StgBindDefault _)
716 (CCallProfCtrMacro SLIT("RET_SEMI_BY_DEFAULT") [], -- ToDo: monadise?
720 st_alt (con, args, use_mask, _)
721 = -- Ha! Nothing to do; Node already points to the thing
723 (CCallProfCtrMacro SLIT("RET_SEMI_IN_HEAP") -- ToDo: monadise?
724 [mkIntCLit (length args)], -- how big the thing in the heap is
728 con_tag = dataConTag con
729 join_label = mkAltLabel uniq con_tag
732 %************************************************************************
734 \subsection[CgCase-prim-alts]{Primitive alternatives}
736 %************************************************************************
738 @cgPrimEvalAlts@ and @cgPrimInlineAlts@ generate suitable @CSwitch@es
739 for dealing with the alternatives of a primitive @case@, given an
740 addressing mode for the thing to scrutinise. It also keeps track of
741 the maximum stack depth encountered down any branch.
743 As usual, no binders in the alternatives are yet bound.
746 cgPrimInlineAlts bndr ty alts deflt
747 = cgPrimAltsWithDefault bndr NoGC (CTemp uniq kind) alts deflt []
749 uniq = getUnique bndr
750 kind = typePrimRep ty
752 cgPrimEvalAlts bndr ty alts deflt
753 = cgPrimAltsWithDefault bndr GCMayHappen (CReg reg) alts deflt [reg]
755 reg = dataReturnConvPrim kind
756 kind = typePrimRep ty
758 cgPrimAltsWithDefault bndr gc_flag scrutinee alts deflt regs
759 = -- first bind the default if necessary
760 (if isDeadBinder bndr
762 else bindNewPrimToAmode bndr scrutinee) `thenC`
763 cgPrimAlts gc_flag scrutinee alts deflt regs
765 cgPrimAlts gc_flag scrutinee alts deflt regs
766 = forkAlts (map (cgPrimAlt gc_flag regs) alts)
767 (cgPrimDefault gc_flag regs deflt)
768 `thenFC` \ (alt_absCs, deflt_absC) ->
770 absC (CSwitch scrutinee alt_absCs deflt_absC)
771 -- CSwitch does sensible things with one or zero alternatives
775 -> [MagicId] -- live registers
776 -> (Literal, StgExpr) -- The alternative
777 -> FCode (Literal, AbstractC) -- Its compiled form
779 cgPrimAlt gc_flag regs (lit, rhs)
780 = getAbsC rhs_code `thenFC` \ absC ->
783 rhs_code = possibleHeapCheck gc_flag False regs [] Nothing (cgExpr rhs)
785 cgPrimDefault :: GCFlag
786 -> [MagicId] -- live registers
790 cgPrimDefault gc_flag regs StgNoDefault
791 = panic "cgPrimDefault: No default in prim case"
793 cgPrimDefault gc_flag regs (StgBindDefault rhs)
794 = getAbsC (possibleHeapCheck gc_flag False regs [] Nothing (cgExpr rhs))
798 %************************************************************************
800 \subsection[CgCase-tidy]{Code for tidying up prior to an eval}
802 %************************************************************************
805 saveVolatileVarsAndRegs
806 :: StgLiveVars -- Vars which should be made safe
807 -> FCode (AbstractC, -- Assignments to do the saves
808 EndOfBlockInfo, -- sequel for the alts
809 Maybe VirtualSpOffset) -- Slot for current cost centre
812 saveVolatileVarsAndRegs vars
813 = saveVolatileVars vars `thenFC` \ var_saves ->
814 saveCurrentCostCentre `thenFC` \ (maybe_cc_slot, cc_save) ->
815 getEndOfBlockInfo `thenFC` \ eob_info ->
816 returnFC (mkAbstractCs [var_saves, cc_save],
821 saveVolatileVars :: StgLiveVars -- Vars which should be made safe
822 -> FCode AbstractC -- Assignments to to the saves
824 saveVolatileVars vars
825 = save_em (varSetElems vars)
827 save_em [] = returnFC AbsCNop
830 = getCAddrModeIfVolatile var `thenFC` \ v ->
832 Nothing -> save_em vars -- Non-volatile, so carry on
835 Just vol_amode -> -- Aha! It's volatile
836 save_var var vol_amode `thenFC` \ abs_c ->
837 save_em vars `thenFC` \ abs_cs ->
838 returnFC (abs_c `mkAbsCStmts` abs_cs)
840 save_var var vol_amode
841 = allocPrimStack (getPrimRepSize kind) `thenFC` \ slot ->
842 rebindToStack var slot `thenC`
843 getSpRelOffset slot `thenFC` \ sp_rel ->
844 returnFC (CAssign (CVal sp_rel kind) vol_amode)
846 kind = getAmodeRep vol_amode
849 ---------------------------------------------------------------------------
851 When we save the current cost centre (which is done for lexical
852 scoping), we allocate a free stack location, and return (a)~the
853 virtual offset of the location, to pass on to the alternatives, and
854 (b)~the assignment to do the save (just as for @saveVolatileVars@).
857 saveCurrentCostCentre ::
858 FCode (Maybe VirtualSpOffset, -- Where we decide to store it
859 AbstractC) -- Assignment to save it
861 saveCurrentCostCentre
862 = if not opt_SccProfilingOn then
863 returnFC (Nothing, AbsCNop)
865 allocPrimStack (getPrimRepSize CostCentreRep) `thenFC` \ slot ->
866 getSpRelOffset slot `thenFC` \ sp_rel ->
868 CAssign (CVal sp_rel CostCentreRep) (CReg CurCostCentre))
870 freeCostCentreSlot :: Maybe VirtualSpOffset -> Code
871 freeCostCentreSlot Nothing = nopC
872 freeCostCentreSlot (Just slot) = freeStackSlots [slot]
874 restoreCurrentCostCentre :: Maybe VirtualSpOffset -> FCode AbstractC
875 restoreCurrentCostCentre Nothing = returnFC AbsCNop
876 restoreCurrentCostCentre (Just slot)
877 = getSpRelOffset slot `thenFC` \ sp_rel ->
878 returnFC (CCallProfCCMacro SLIT("RESTORE_CCCS") [CVal sp_rel CostCentreRep])
879 -- we use the RESTORE_CCCS macro, rather than just
880 -- assigning into CurCostCentre, in case RESTORE_CCC
881 -- has some sanity-checking in it.
884 %************************************************************************
886 \subsection[CgCase-return-vec]{Building a return vector}
888 %************************************************************************
890 Build a return vector, and return a suitable label addressing
894 mkReturnVector :: Unique
895 -> [(ConTag, AbstractC)] -- Branch codes
896 -> AbstractC -- Default case
897 -> SRT -- continuation's SRT
898 -> Liveness -- stack liveness
899 -> CtrlReturnConvention
902 mkReturnVector uniq tagged_alt_absCs deflt_absC srt liveness ret_conv
903 = getSRTLabel `thenFC` \srt_label ->
905 srt_info = (srt_label, srt)
907 (return_vec_amode, vtbl_body) = case ret_conv of {
909 -- might be a polymorphic case...
910 UnvectoredReturn 0 ->
911 ASSERT(null tagged_alt_absCs)
912 (CLbl ret_label RetRep,
913 absC (CRetDirect uniq deflt_absC (srt_label, srt) liveness));
915 UnvectoredReturn n ->
916 -- find the tag explicitly rather than using tag_reg for now.
917 -- on architectures with lots of regs the tag will be loaded
918 -- into tag_reg by the code doing the returning.
920 tag = CMacroExpr WordRep GET_TAG [CVal (nodeRel 0) DataPtrRep]
922 (CLbl ret_label RetRep,
923 absC (CRetDirect uniq
924 (mkAlgAltsCSwitch tag tagged_alt_absCs deflt_absC)
928 VectoredReturn table_size ->
930 (vector_table, alts_absC) =
931 unzip (map mk_vector_entry [fIRST_TAG .. (table_size+fIRST_TAG-1)])
933 ret_vector = CRetVector vtbl_label
935 (srt_label, srt) liveness
937 (CLbl vtbl_label DataPtrRep,
938 -- alts come first, because we don't want to declare all the symbols
939 absC (mkAbstractCs (mkAbstractCs alts_absC : [deflt_absC,ret_vector]))
944 returnFC return_vec_amode
948 vtbl_label = mkVecTblLabel uniq
949 ret_label = mkReturnInfoLabel uniq
952 case nonemptyAbsC deflt_absC of
953 -- the simplifier might have eliminated a case
954 Nothing -> CLbl mkErrorStdEntryLabel CodePtrRep
955 Just absC@(CCodeBlock lbl _) -> CLbl lbl CodePtrRep
957 mk_vector_entry :: ConTag -> (CAddrMode, AbstractC)
959 = case [ absC | (t, absC) <- tagged_alt_absCs, t == tag ] of
960 [] -> (deflt_lbl, AbsCNop)
961 [absC@(CCodeBlock lbl _)] -> (CLbl lbl CodePtrRep,absC)
962 _ -> panic "mkReturnVector: too many"
965 %************************************************************************
967 \subsection[CgCase-utils]{Utilities for handling case expressions}
969 %************************************************************************
971 @possibleHeapCheck@ tests a flag passed in to decide whether to do a
972 heap check or not. These heap checks are always in a case
973 alternative, so we use altHeapCheck.
978 -> Bool -- True <=> algebraic case
979 -> [MagicId] -- live registers
980 -> [(VirtualSpOffset,Int)] -- stack slots to tag
981 -> Maybe CLabel -- return address
982 -> Code -- continuation
985 possibleHeapCheck GCMayHappen is_alg regs tags lbl code
986 = altHeapCheck is_alg regs tags AbsCNop lbl code
987 possibleHeapCheck NoGC _ _ tags lbl code
991 splitTyConAppThroughNewTypes is like splitTyConApp_maybe except
992 that it looks through newtypes in addition to synonyms. It's
993 useful in the back end where we're not interested in newtypes
996 Sometimes, we've thrown away the constructors during pruning in the
997 renamer. In these cases, we emit a warning and fall back to using a
998 SEQ_FRAME to evaluate the case scrutinee.
1001 getScrutineeTyCon :: Type -> Maybe TyCon
1002 getScrutineeTyCon ty =
1003 case (splitTyConAppThroughNewTypes ty) of
1006 if isFunTyCon tc then Nothing else -- not interested in funs
1007 if isPrimTyCon tc then Just tc else -- return primitive tycons
1008 -- otherwise (algebraic tycons) check the no. of constructors
1009 case (tyConFamilySize tc) of
1010 0 -> pprTrace "Warning" (hcat [
1011 text "constructors for ",
1013 text " not available.\n\tUse -fno-prune-tydecls to fix."
1017 splitTyConAppThroughNewTypes :: Type -> Maybe (TyCon, [Type])
1018 splitTyConAppThroughNewTypes ty
1019 = case splitTyConApp_maybe ty of
1021 | isNewTyCon tc -> splitTyConAppThroughNewTypes ty
1022 | otherwise -> Just (tc, tys)
1024 ([ty], _) = splitFunTys (applyTys (dataConType (head (tyConDataCons tc))) tys)