2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
4 %********************************************************
6 \section[CgCase]{Converting @StgCase@ expressions}
8 %********************************************************
11 #include "HsVersions.h"
13 module CgCase ( cgCase, saveVolatileVarsAndRegs ) where
16 import CgLoop2 ( cgExpr, getPrimOpArgAmodes )
22 import AbsCUtils ( mkAbstractCs, mkAbsCStmts, mkAlgAltsCSwitch,
23 magicIdPrimRep, getAmodeRep
25 import CgBindery ( getVolatileRegs, getArgAmode, getArgAmodes,
26 bindNewToReg, bindNewToTemp,
28 rebindToAStack, rebindToBStack,
29 getCAddrModeAndInfo, getCAddrModeIfVolatile,
32 import CgCon ( buildDynCon, bindConArgs )
33 import CgHeapery ( heapCheck )
34 import CgRetConv ( dataReturnConvAlg, dataReturnConvPrim,
36 DataReturnConvention(..), CtrlReturnConvention(..),
37 assignPrimOpResultRegs,
40 import CgStackery ( allocAStack, allocBStack )
41 import CgTailCall ( tailCallBusiness, performReturn )
42 import CgUsages ( getSpARelOffset, getSpBRelOffset, freeBStkSlot )
43 import CLabel ( mkVecTblLabel, mkReturnPtLabel, mkDefaultLabel,
44 mkAltLabel, mkClosureLabel
46 import ClosureInfo ( mkConLFInfo, mkLFArgument, layOutDynCon )
47 import CmdLineOpts ( opt_SccProfilingOn )
48 import CostCentre ( useCurrentCostCentre )
49 import HeapOffs ( VirtualSpBOffset(..), VirtualHeapOffset(..) )
50 import Id ( idPrimRep, toplevelishId,
51 dataConTag, fIRST_TAG, ConTag(..),
52 isDataCon, DataCon(..),
53 idSetToList, GenId{-instance Uniquable,Eq-}
55 import Maybes ( catMaybes )
56 import PprStyle ( PprStyle(..) )
57 import PprType ( GenType{-instance Outputable-} )
58 import PrimOp ( primOpCanTriggerGC, PrimOp(..) )
59 import PrimRep ( getPrimRepSize, isFollowableRep, retPrimRepSize,
62 import TyCon ( isEnumerationTyCon )
63 import Type ( typePrimRep,
64 getDataSpecTyCon, getDataSpecTyCon_maybe,
67 import Util ( sortLt, isIn, isn'tIn, zipEqual,
68 pprError, panic, assertPanic
71 getDataSpecTyCon = panic "CgCase.getDataSpecTyCon (ToDo)"
72 getDataSpecTyCon_maybe = panic "CgCase.getDataSpecTyCon_maybe (ToDo)"
77 = GCMayHappen -- The scrutinee may involve GC, so everything must be
78 -- tidy before the code for the scrutinee.
80 | NoGC -- The scrutinee is a primitive value, or a call to a
81 -- primitive op which does no GC. Hence the case can
82 -- be done inline, without tidying up first.
85 It is quite interesting to decide whether to put a heap-check
86 at the start of each alternative. Of course we certainly have
87 to do so if the case forces an evaluation, or if there is a primitive
88 op which can trigger GC.
90 A more interesting situation is this:
97 default -> !C!; ...C...
100 where \tr{!x!} indicates a possible heap-check point. The heap checks
101 in the alternatives {\em can} be omitted, in which case the topmost
102 heapcheck will take their worst case into account.
104 In favour of omitting \tr{!B!}, \tr{!C!}:
108 {\em May} save a heap overflow test,
109 if ...A... allocates anything. The other advantage
110 of this is that we can use relative addressing
111 from a single Hp to get at all the closures so allocated.
113 No need to save volatile vars etc across the case
120 May do more allocation than reqd. This sometimes bites us
121 badly. For example, nfib (ha!) allocates about 30\% more space if the
122 worst-casing is done, because many many calls to nfib are leaf calls
123 which don't need to allocate anything.
125 This never hurts us if there is only one alternative.
129 *** NOT YET DONE *** The difficulty is that \tr{!B!}, \tr{!C!} need
130 to take account of what is live, and that includes all live volatile
131 variables, even if they also have stable analogues. Furthermore, the
132 stack pointers must be lined up properly so that GC sees tidy stacks.
133 If these things are done, then the heap checks can be done at \tr{!B!} and
134 \tr{!C!} without a full save-volatile-vars sequence.
145 Several special cases for primitive operations.
147 ******* TO DO TO DO: fix what follows
151 case (op x1 ... xn) of
154 where the type of the case scrutinee is a multi-constuctor algebraic type.
155 Then we simply compile code for
163 case (op x1 ... xn) of
167 where the type of the case scrutinee is a multi-constuctor algebraic type.
168 we just bomb out at the moment. It never happens in practice.
170 **** END OF TO DO TO DO
173 cgCase scrut@(StgPrim op args _) live_in_whole_case live_in_alts uniq
174 (StgAlgAlts _ alts (StgBindDefault id _ deflt_rhs))
175 = if not (null alts) then
176 panic "cgCase: case on PrimOp with default *and* alts\n"
177 -- For now, die if alts are non-empty
180 pprTrace "cgCase:prim app returning alg data type: bad code!" (ppr PprDebug scrut) $
181 -- See above TO DO TO DO
183 cgExpr (StgLet (StgNonRec id scrut_rhs) deflt_rhs)
185 scrut_rhs = StgRhsClosure useCurrentCostCentre stgArgOcc{-safe-} scrut_free_vars
187 scrut_free_vars = [ fv | StgVarArg fv <- args, not (toplevelishId fv) ]
193 cgCase (StgPrim op args _) live_in_whole_case live_in_alts uniq alts
194 | not (primOpCanTriggerGC op)
196 -- Get amodes for the arguments and results
197 getPrimOpArgAmodes op args `thenFC` \ arg_amodes ->
199 result_amodes = getPrimAppResultAmodes uniq alts
200 liveness_mask = panic "cgCase: liveness of non-GC-ing primop touched\n"
202 -- Perform the operation
203 getVolatileRegs live_in_alts `thenFC` \ vol_regs ->
205 absC (COpStmt result_amodes op
206 arg_amodes -- note: no liveness arg
207 liveness_mask vol_regs) `thenC`
209 -- Scrutinise the result
210 cgInlineAlts NoGC uniq alts
212 | otherwise -- *Can* trigger GC
213 = getPrimOpArgAmodes op args `thenFC` \ arg_amodes ->
215 -- Get amodes for the arguments and results, and assign to regs
216 -- (Can-trigger-gc primops guarantee to have their (nonRobust)
219 op_result_regs = assignPrimOpResultRegs op
221 op_result_amodes = map CReg op_result_regs
223 (op_arg_amodes, liveness_mask, arg_assts)
224 = makePrimOpArgsRobust op arg_amodes
226 liveness_arg = mkIntCLit liveness_mask
228 -- Tidy up in case GC happens...
230 -- Nota Bene the use of live_in_whole_case in nukeDeadBindings.
231 -- Reason: the arg_assts computed above may refer to some stack slots
232 -- which are not live in the alts. So we mustn't use those slots
233 -- to save volatile vars in!
234 nukeDeadBindings live_in_whole_case `thenC`
235 saveVolatileVars live_in_alts `thenFC` \ volatile_var_save_assts ->
237 getEndOfBlockInfo `thenFC` \ eob_info ->
238 forkEval eob_info nopC
239 (getAbsC (cgInlineAlts GCMayHappen uniq alts) `thenFC` \ abs_c ->
240 absC (CRetUnVector vtbl_label (CLabelledCode return_label abs_c))
242 returnFC (CaseAlts (CUnVecLbl return_label vtbl_label)
243 Nothing{-no semi-tagging-}))
244 `thenFC` \ new_eob_info ->
246 -- Record the continuation info
247 setEndOfBlockInfo new_eob_info (
249 -- Now "return" to the inline alternatives; this will get
250 -- compiled to a fall-through.
252 simultaneous_assts = arg_assts `mkAbsCStmts` volatile_var_save_assts
254 -- do_op_and_continue will be passed an amode for the continuation
255 do_op_and_continue sequel
256 = absC (COpStmt op_result_amodes
258 (pin_liveness op liveness_arg op_arg_amodes)
263 sequelToAmode sequel `thenFC` \ dest_amode ->
264 absC (CReturn dest_amode DirectReturn)
266 -- Note: we CJump even for algebraic data types,
267 -- because cgInlineAlts always generates code, never a
270 performReturn simultaneous_assts do_op_and_continue live_in_alts
273 -- for all PrimOps except ccalls, we pin the liveness info
274 -- on as the first "argument"
275 -- ToDo: un-duplicate?
277 pin_liveness (CCallOp _ _ _ _ _) _ args = args
278 pin_liveness other_op liveness_arg args
281 vtbl_label = mkVecTblLabel uniq
282 return_label = mkReturnPtLabel uniq
286 Another special case: scrutinising a primitive-typed variable. No
287 evaluation required. We don't save volatile variables, nor do we do a
288 heap-check in the alternatives. Instead, the heap usage of the
289 alternatives is worst-cased and passed upstream. This can result in
290 allocating more heap than strictly necessary, but it will sometimes
291 eliminate a heap check altogether.
294 cgCase (StgApp v [] _) live_in_whole_case live_in_alts uniq (StgPrimAlts ty alts deflt)
295 = getArgAmode v `thenFC` \ amode ->
296 cgPrimAltsGivenScrutinee NoGC amode alts deflt
299 Special case: scrutinising a non-primitive variable.
300 This can be done a little better than the general case, because
301 we can reuse/trim the stack slot holding the variable (if it is in one).
304 cgCase (StgApp (StgVarArg fun) args _ {-lvs must be same as live_in_alts-})
305 live_in_whole_case live_in_alts uniq alts@(StgAlgAlts _ _ _)
307 getCAddrModeAndInfo fun `thenFC` \ (fun_amode, lf_info) ->
308 getArgAmodes args `thenFC` \ arg_amodes ->
310 -- Squish the environment
311 nukeDeadBindings live_in_alts `thenC`
312 saveVolatileVarsAndRegs live_in_alts
313 `thenFC` \ (save_assts, alts_eob_info, maybe_cc_slot) ->
315 forkEval alts_eob_info
316 nopC (cgEvalAlts maybe_cc_slot uniq alts) `thenFC` \ scrut_eob_info ->
317 setEndOfBlockInfo scrut_eob_info (
318 tailCallBusiness fun fun_amode lf_info arg_amodes live_in_alts save_assts
323 Finally, here is the general case.
326 cgCase expr live_in_whole_case live_in_alts uniq alts
327 = -- Figure out what volatile variables to save
328 nukeDeadBindings live_in_whole_case `thenC`
329 saveVolatileVarsAndRegs live_in_alts
330 `thenFC` \ (save_assts, alts_eob_info, maybe_cc_slot) ->
332 -- Save those variables right now!
333 absC save_assts `thenC`
335 forkEval alts_eob_info
336 (nukeDeadBindings live_in_alts)
337 (cgEvalAlts maybe_cc_slot uniq alts) `thenFC` \ scrut_eob_info ->
339 setEndOfBlockInfo scrut_eob_info (cgExpr expr)
342 %************************************************************************
344 \subsection[CgCase-primops]{Primitive applications}
346 %************************************************************************
348 Get result amodes for a primitive operation, in the case wher GC can't happen.
349 The amodes are returned in canonical order, ready for the prim-op!
351 Alg case: temporaries named as in the alternatives,
352 plus (CTemp u) for the tag (if needed)
355 This is all disgusting, because these amodes must be consistent with those
356 invented by CgAlgAlts.
359 getPrimAppResultAmodes
366 -- If there's an StgBindDefault which does use the bound
367 -- variable, then we can only handle it if the type involved is
368 -- an enumeration type. That's important in the case
374 -- The only reason for the restriction to *enumeration* types is our
375 -- inability to invent suitable temporaries to hold the results;
376 -- Elaborating the CTemp addr mode to have a second uniq field
377 -- (which would simply count from 1) would solve the problem.
378 -- Anyway, cgInlineAlts is now capable of handling all cases;
379 -- it's only this function which is being wimpish.
381 getPrimAppResultAmodes uniq (StgAlgAlts ty alts (StgBindDefault _ True {- used -} _))
382 | isEnumerationTyCon spec_tycon = [tag_amode]
383 | otherwise = panic "getPrimAppResultAmodes: non-enumeration algebraic alternatives with default"
385 -- A temporary variable to hold the tag; this is unaffected by GC because
386 -- the heap-checks in the branches occur after the switch
387 tag_amode = CTemp uniq IntRep
388 (spec_tycon, _, _) = getDataSpecTyCon ty
390 getPrimAppResultAmodes uniq (StgAlgAlts ty alts other_default)
391 -- Default is either StgNoDefault or StgBindDefault with unused binder
393 [_] -> arg_amodes -- No need for a tag
394 other -> tag_amode : arg_amodes
396 -- A temporary variable to hold the tag; this is unaffected by GC because
397 -- the heap-checks in the branches occur after the switch
398 tag_amode = CTemp uniq IntRep
400 -- Sort alternatives into canonical order; there must be a complete
401 -- set because there's no default case.
402 sorted_alts = sortLt lt alts
403 (con1,_,_,_) `lt` (con2,_,_,_) = dataConTag con1 < dataConTag con2
405 arg_amodes :: [CAddrMode]
407 -- Turn them into amodes
408 arg_amodes = concat (map mk_amodes sorted_alts)
409 mk_amodes (con, args, use_mask, rhs)
410 = [ CTemp (uniqueOf arg) (idPrimRep arg) | arg <- args ]
413 The situation is simpler for primitive
414 results, because there is only one!
417 getPrimAppResultAmodes uniq (StgPrimAlts ty _ _)
418 = [CTemp uniq (typePrimRep ty)]
422 %************************************************************************
424 \subsection[CgCase-alts]{Alternatives}
426 %************************************************************************
428 @cgEvalAlts@ returns an addressing mode for a continuation for the
429 alternatives of a @case@, used in a context when there
430 is some evaluation to be done.
433 cgEvalAlts :: Maybe VirtualSpBOffset -- Offset of cost-centre to be restored, if any
436 -> FCode Sequel -- Any addr modes inside are guaranteed to be a label
437 -- so that we can duplicate it without risk of
440 cgEvalAlts cc_slot uniq (StgAlgAlts ty alts deflt)
441 = -- Generate the instruction to restore cost centre, if any
442 restoreCurrentCostCentre cc_slot `thenFC` \ cc_restore ->
444 -- Generate sequel info for use downstream
445 -- At the moment, we only do it if the type is vector-returnable.
446 -- Reason: if not, then it costs extra to label the
447 -- alternatives, because we'd get return code like:
449 -- switch TagReg { 0 : JMP(alt_1); 1 : JMP(alt_2) ..etc }
451 -- which is worse than having the alt code in the switch statement
454 (spec_tycon, _, _) = getDataSpecTyCon ty
457 = case ctrlReturnConvAlg spec_tycon of
458 VectoredReturn _ -> True
462 = if not use_labelled_alts then
463 Nothing -- no semi-tagging info
465 cgSemiTaggedAlts uniq alts deflt -- Just <something>
467 cgAlgAlts GCMayHappen uniq cc_restore use_labelled_alts ty alts deflt
468 `thenFC` \ (tagged_alt_absCs, deflt_absC) ->
470 mkReturnVector uniq ty tagged_alt_absCs deflt_absC `thenFC` \ return_vec ->
472 returnFC (CaseAlts return_vec semi_tagged_stuff)
474 cgEvalAlts cc_slot uniq (StgPrimAlts ty alts deflt)
475 = -- Generate the instruction to restore cost centre, if any
476 restoreCurrentCostCentre cc_slot `thenFC` \ cc_restore ->
478 -- Generate the switch
479 getAbsC (cgPrimAlts GCMayHappen uniq ty alts deflt) `thenFC` \ abs_c ->
481 -- Generate the labelled block, starting with restore-cost-centre
482 absC (CRetUnVector vtbl_label
483 (CLabelledCode return_label (cc_restore `mkAbsCStmts` abs_c)))
485 -- Return an amode for the block
486 returnFC (CaseAlts (CUnVecLbl return_label vtbl_label) Nothing{-no semi-tagging-})
488 vtbl_label = mkVecTblLabel uniq
489 return_label = mkReturnPtLabel uniq
494 cgInlineAlts :: GCFlag -> Unique
499 First case: algebraic case, exactly one alternative, no default.
500 In this case the primitive op will not have set a temporary to the
501 tag, so we shouldn't generate a switch statment. Instead we just
505 cgInlineAlts gc_flag uniq (StgAlgAlts ty [alt@(con,args,use_mask,rhs)] StgNoDefault)
506 = cgAlgAltRhs gc_flag con args use_mask rhs
509 Second case: algebraic case, several alternatives.
510 Tag is held in a temporary.
513 cgInlineAlts gc_flag uniq (StgAlgAlts ty alts deflt)
514 = cgAlgAlts gc_flag uniq AbsCNop{-restore_cc-} False{-no semi-tagging-}
515 ty alts deflt `thenFC` \ (tagged_alts, deflt_c) ->
518 absC (mkAlgAltsCSwitch tag_amode tagged_alts deflt_c)
520 -- A temporary variable to hold the tag; this is unaffected by GC because
521 -- the heap-checks in the branches occur after the switch
522 tag_amode = CTemp uniq IntRep
525 Third (real) case: primitive result type.
528 cgInlineAlts gc_flag uniq (StgPrimAlts ty alts deflt)
529 = cgPrimAlts gc_flag uniq ty alts deflt
533 %************************************************************************
535 \subsection[CgCase-alg-alts]{Algebraic alternatives}
537 %************************************************************************
539 In @cgAlgAlts@, none of the binders in the alternatives are
540 assumed to be yet bound.
545 -> AbstractC -- Restore-cost-centre instruction
546 -> Bool -- True <=> branches must be labelled
547 -> Type -- From the case statement
548 -> [(Id, [Id], [Bool], StgExpr)] -- The alternatives
549 -> StgCaseDefault -- The default
550 -> FCode ([(ConTag, AbstractC)], -- The branches
551 AbstractC -- The default case
555 The case with a default which has a binder is different. We need to
556 pick all the constructors which aren't handled explicitly by an
557 alternative, and which return their results in registers, allocate
558 them explicitly in the heap, and jump to a join point for the default
561 OLD: All of this only works if a heap-check is required anyway, because
562 otherwise it isn't safe to allocate.
564 NEW (July 94): now false! It should work regardless of gc_flag,
565 because of the extra_branches argument now added to forkAlts.
567 We put a heap-check at the join point, for the benefit of constructors
568 which don't need to do allocation. This means that ones which do need
569 to allocate may end up doing two heap-checks; but that's just too bad.
570 (We'd need two join labels otherwise. ToDo.)
572 It's all pretty turgid anyway.
575 cgAlgAlts gc_flag uniq restore_cc semi_tagging
576 ty alts deflt@(StgBindDefault binder True{-used-} _)
578 extra_branches :: [FCode (ConTag, AbstractC)]
579 extra_branches = catMaybes (map mk_extra_branch default_cons)
581 must_label_default = semi_tagging || not (null extra_branches)
583 forkAlts (map (cgAlgAlt gc_flag uniq restore_cc semi_tagging) alts)
585 (cgAlgDefault gc_flag uniq restore_cc must_label_default deflt)
588 default_join_lbl = mkDefaultLabel uniq
589 jump_instruction = CJump (CLbl default_join_lbl CodePtrRep)
591 (spec_tycon, _, spec_cons) = getDataSpecTyCon ty
593 alt_cons = [ con | (con,_,_,_) <- alts ]
595 default_cons = [ spec_con | spec_con <- spec_cons, -- In this type
596 spec_con `not_elem` alt_cons ] -- Not handled explicitly
598 not_elem = isn'tIn "cgAlgAlts"
600 -- (mk_extra_branch con) returns the a maybe for the extra branch for con.
601 -- The "maybe" is because con may return in heap, in which case there is
602 -- nothing to do. Otherwise, we have a special case for a nullary constructor,
603 -- but in the general case we do an allocation and heap-check.
605 mk_extra_branch :: DataCon -> (Maybe (FCode (ConTag, AbstractC)))
608 = ASSERT(isDataCon con)
609 case dataReturnConvAlg con of
610 ReturnInHeap -> Nothing
611 ReturnInRegs rs -> Just (getAbsC (alloc_code rs) `thenFC` \ abs_c ->
612 returnFC (tag, abs_c)
615 lf_info = mkConLFInfo con
617 closure_lbl = mkClosureLabel con
619 -- alloc_code generates code to allocate constructor con, whose args are
620 -- in the arguments to alloc_code, assigning the result to Node.
621 alloc_code :: [MagicId] -> Code
624 = possibleHeapCheck gc_flag regs False (
625 buildDynCon binder useCurrentCostCentre con
626 (map CReg regs) (all zero_size regs)
628 idInfoToAmode PtrRep idinfo `thenFC` \ amode ->
630 absC (CAssign (CReg node) amode) `thenC`
631 absC jump_instruction
634 zero_size reg = getPrimRepSize (magicIdPrimRep reg) == 0
637 Now comes the general case
640 cgAlgAlts gc_flag uniq restore_cc must_label_branches ty alts deflt
641 {- The deflt is either StgNoDefault or a BindDefault which doesn't use the binder -}
642 = forkAlts (map (cgAlgAlt gc_flag uniq restore_cc must_label_branches) alts)
643 [{- No "extra branches" -}]
644 (cgAlgDefault gc_flag uniq restore_cc must_label_branches deflt)
648 cgAlgDefault :: GCFlag
649 -> Unique -> AbstractC -> Bool -- turgid state...
650 -> StgCaseDefault -- input
651 -> FCode AbstractC -- output
653 cgAlgDefault gc_flag uniq restore_cc must_label_branch
657 cgAlgDefault gc_flag uniq restore_cc must_label_branch
658 (StgBindDefault _ False{-binder not used-} rhs)
660 = getAbsC (absC restore_cc `thenC`
661 possibleHeapCheck gc_flag [] False (cgExpr rhs)) `thenFC` \ abs_c ->
663 final_abs_c | must_label_branch = CJump (CLabelledCode lbl abs_c)
668 lbl = mkDefaultLabel uniq
671 cgAlgDefault gc_flag uniq restore_cc must_label_branch
672 (StgBindDefault binder True{-binder used-} rhs)
674 = -- We have arranged that Node points to the thing, even
675 -- even if we return in registers
676 bindNewToReg binder node mkLFArgument `thenC`
677 getAbsC (absC restore_cc `thenC`
678 possibleHeapCheck gc_flag [node] False (cgExpr rhs)
679 -- Node is live, but doesn't need to point at the thing itself;
680 -- it's ok for Node to point to an indirection or FETCH_ME
681 -- Hence no need to re-enter Node.
682 ) `thenFC` \ abs_c ->
685 final_abs_c | must_label_branch = CJump (CLabelledCode lbl abs_c)
690 lbl = mkDefaultLabel uniq
694 -> Unique -> AbstractC -> Bool -- turgid state
695 -> (Id, [Id], [Bool], StgExpr)
696 -> FCode (ConTag, AbstractC)
698 cgAlgAlt gc_flag uniq restore_cc must_label_branch (con, args, use_mask, rhs)
699 = getAbsC (absC restore_cc `thenC`
700 cgAlgAltRhs gc_flag con args use_mask rhs) `thenFC` \ abs_c ->
702 final_abs_c | must_label_branch = CJump (CLabelledCode lbl abs_c)
705 returnFC (tag, final_abs_c)
708 lbl = mkAltLabel uniq tag
710 cgAlgAltRhs :: GCFlag -> Id -> [Id] -> [Bool] -> StgExpr -> Code
712 cgAlgAltRhs gc_flag con args use_mask rhs
714 (live_regs, node_reqd)
715 = case (dataReturnConvAlg con) of
716 ReturnInHeap -> ([], True)
717 ReturnInRegs regs -> ([reg | (reg,True) <- regs `zipEqual` use_mask], False)
718 -- Pick the live registers using the use_mask
719 -- Doing so is IMPORTANT, because with semi-tagging
720 -- enabled only the live registers will have valid
723 possibleHeapCheck gc_flag live_regs node_reqd (
725 NoGC -> mapFCs bindNewToTemp args `thenFC` \ _ ->
727 GCMayHappen -> bindConArgs con args
733 %************************************************************************
735 \subsection[CgCase-semi-tagged-alts]{The code to deal with sem-tagging}
737 %************************************************************************
739 Turgid-but-non-monadic code to conjure up the required info from
740 algebraic case alternatives for semi-tagging.
743 cgSemiTaggedAlts :: Unique
744 -> [(Id, [Id], [Bool], StgExpr)]
745 -> GenStgCaseDefault Id Id
748 cgSemiTaggedAlts uniq alts deflt
749 = Just (map st_alt alts, st_deflt deflt)
751 st_deflt StgNoDefault = Nothing
753 st_deflt (StgBindDefault binder binder_used _)
754 = Just (if binder_used then Just binder else Nothing,
755 (CCallProfCtrMacro SLIT("RET_SEMI_BY_DEFAULT") [], -- ToDo: monadise?
759 st_alt (con, args, use_mask, _)
760 = case (dataReturnConvAlg con) of
763 -- Ha! Nothing to do; Node already points to the thing
765 (CCallProfCtrMacro SLIT("RET_SEMI_IN_HEAP") -- ToDo: monadise?
766 [mkIntCLit (length args)], -- how big the thing in the heap is
771 -- We have to load the live registers from the constructor
772 -- pointed to by Node.
774 (_, regs_w_offsets) = layOutDynCon con magicIdPrimRep regs
776 used_regs = selectByMask use_mask regs
778 used_regs_w_offsets = [ ro | ro@(reg,offset) <- regs_w_offsets,
779 reg `is_elem` used_regs]
781 is_elem = isIn "cgSemiTaggedAlts"
785 CCallProfCtrMacro SLIT("RET_SEMI_IN_REGS") -- ToDo: macroise?
786 [mkIntCLit (length regs_w_offsets),
787 mkIntCLit (length used_regs_w_offsets)],
788 CSimultaneous (mkAbstractCs (map move_to_reg used_regs_w_offsets))],
791 con_tag = dataConTag con
792 join_label = mkAltLabel uniq con_tag
794 move_to_reg :: (MagicId, VirtualHeapOffset {-from Node-}) -> AbstractC
795 move_to_reg (reg, offset)
796 = CAssign (CReg reg) (CVal (NodeRel offset) (magicIdPrimRep reg))
799 %************************************************************************
801 \subsection[CgCase-prim-alts]{Primitive alternatives}
803 %************************************************************************
805 @cgPrimAlts@ generates a suitable @CSwitch@ for dealing with the
806 alternatives of a primitive @case@, given an addressing mode for the
807 thing to scrutinise. It also keeps track of the maximum stack depth
808 encountered down any branch.
810 As usual, no binders in the alternatives are yet bound.
816 -> [(Literal, StgExpr)] -- Alternatives
817 -> StgCaseDefault -- Default
820 cgPrimAlts gc_flag uniq ty alts deflt
821 = cgPrimAltsGivenScrutinee gc_flag scrutinee alts deflt
823 -- A temporary variable, or standard register, to hold the result
824 scrutinee = case gc_flag of
825 NoGC -> CTemp uniq kind
826 GCMayHappen -> CReg (dataReturnConvPrim kind)
828 kind = typePrimRep ty
831 cgPrimAltsGivenScrutinee gc_flag scrutinee alts deflt
832 = forkAlts (map (cgPrimAlt gc_flag) alts)
833 [{- No "extra branches" -}]
834 (cgPrimDefault gc_flag scrutinee deflt) `thenFC` \ (alt_absCs, deflt_absC) ->
835 absC (CSwitch scrutinee alt_absCs deflt_absC)
836 -- CSwitch does sensible things with one or zero alternatives
840 -> (Literal, StgExpr) -- The alternative
841 -> FCode (Literal, AbstractC) -- Its compiled form
843 cgPrimAlt gc_flag (lit, rhs)
844 = getAbsC rhs_code `thenFC` \ absC ->
847 rhs_code = possibleHeapCheck gc_flag [] False (cgExpr rhs )
849 cgPrimDefault :: GCFlag
850 -> CAddrMode -- Scrutinee
854 cgPrimDefault gc_flag scrutinee StgNoDefault
855 = panic "cgPrimDefault: No default in prim case"
857 cgPrimDefault gc_flag scrutinee (StgBindDefault _ False{-binder not used-} rhs)
858 = getAbsC (possibleHeapCheck gc_flag [] False (cgExpr rhs ))
860 cgPrimDefault gc_flag scrutinee (StgBindDefault binder True{-used-} rhs)
861 = getAbsC (possibleHeapCheck gc_flag regs False rhs_code)
863 regs = if isFollowableRep (getAmodeRep scrutinee) then
866 rhs_code = bindNewPrimToAmode binder scrutinee `thenC`
871 %************************************************************************
873 \subsection[CgCase-tidy]{Code for tidying up prior to an eval}
875 %************************************************************************
878 saveVolatileVarsAndRegs
879 :: StgLiveVars -- Vars which should be made safe
880 -> FCode (AbstractC, -- Assignments to do the saves
881 EndOfBlockInfo, -- New sequel, recording where the return
883 Maybe VirtualSpBOffset) -- Slot for current cost centre
886 saveVolatileVarsAndRegs vars
887 = saveVolatileVars vars `thenFC` \ var_saves ->
888 saveCurrentCostCentre `thenFC` \ (maybe_cc_slot, cc_save) ->
889 saveReturnAddress `thenFC` \ (new_eob_info, ret_save) ->
890 returnFC (mkAbstractCs [var_saves, cc_save, ret_save],
895 saveVolatileVars :: StgLiveVars -- Vars which should be made safe
896 -> FCode AbstractC -- Assignments to to the saves
898 saveVolatileVars vars
899 = save_em (idSetToList vars)
901 save_em [] = returnFC AbsCNop
904 = getCAddrModeIfVolatile var `thenFC` \ v ->
906 Nothing -> save_em vars -- Non-volatile, so carry on
909 Just vol_amode -> -- Aha! It's volatile
910 save_var var vol_amode `thenFC` \ abs_c ->
911 save_em vars `thenFC` \ abs_cs ->
912 returnFC (abs_c `mkAbsCStmts` abs_cs)
914 save_var var vol_amode
915 | isFollowableRep kind
916 = allocAStack `thenFC` \ a_slot ->
917 rebindToAStack var a_slot `thenC`
918 getSpARelOffset a_slot `thenFC` \ spa_rel ->
919 returnFC (CAssign (CVal spa_rel kind) vol_amode)
921 = allocBStack (getPrimRepSize kind) `thenFC` \ b_slot ->
922 rebindToBStack var b_slot `thenC`
923 getSpBRelOffset b_slot `thenFC` \ spb_rel ->
924 returnFC (CAssign (CVal spb_rel kind) vol_amode)
926 kind = getAmodeRep vol_amode
928 saveReturnAddress :: FCode (EndOfBlockInfo, AbstractC)
930 = getEndOfBlockInfo `thenFC` \ eob_info@(EndOfBlockInfo vA vB sequel) ->
932 -- See if it is volatile
934 InRetReg -> -- Yes, it's volatile
935 allocBStack retPrimRepSize `thenFC` \ b_slot ->
936 getSpBRelOffset b_slot `thenFC` \ spb_rel ->
938 returnFC (EndOfBlockInfo vA vB (OnStack b_slot),
939 CAssign (CVal spb_rel RetRep) (CReg RetReg))
941 UpdateCode _ -> -- It's non-volatile all right, but we still need
942 -- to allocate a B-stack slot for it, *solely* to make
943 -- sure that update frames for different values do not
944 -- appear adjacent on the B stack. This makes sure
945 -- that B-stack squeezing works ok.
947 allocBStack retPrimRepSize `thenFC` \ b_slot ->
948 returnFC (eob_info, AbsCNop)
950 other -> -- No, it's non-volatile, so do nothing
951 returnFC (eob_info, AbsCNop)
954 Note about B-stack squeezing. Consider the following:`
956 y = [...] \u [] -> ...
957 x = [y] \u [] -> case y of (a,b) -> a
959 The code for x will push an update frame, and then enter y. The code
960 for y will push another update frame. If the B-stack-squeezer then
961 wakes up, it will see two update frames right on top of each other,
962 and will combine them. This is WRONG, of course, because x's value is
965 The fix implemented above makes sure that we allocate an (unused)
966 B-stack slot before entering y. You can think of this as holding the
967 saved value of RetAddr, which (after pushing x's update frame will be
968 some update code ptr). The compiler is clever enough to load the
969 static update code ptr into RetAddr before entering ~a~, but the slot
970 is still there to separate the update frames.
972 When we save the current cost centre (which is done for lexical
973 scoping), we allocate a free B-stack location, and return (a)~the
974 virtual offset of the location, to pass on to the alternatives, and
975 (b)~the assignment to do the save (just as for @saveVolatileVars@).
978 saveCurrentCostCentre ::
979 FCode (Maybe VirtualSpBOffset, -- Where we decide to store it
980 -- Nothing if not lexical CCs
981 AbstractC) -- Assignment to save it
982 -- AbsCNop if not lexical CCs
984 saveCurrentCostCentre
986 doing_profiling = opt_SccProfilingOn
988 if not doing_profiling then
989 returnFC (Nothing, AbsCNop)
991 allocBStack (getPrimRepSize CostCentreRep) `thenFC` \ b_slot ->
992 getSpBRelOffset b_slot `thenFC` \ spb_rel ->
993 returnFC (Just b_slot,
994 CAssign (CVal spb_rel CostCentreRep) (CReg CurCostCentre))
996 restoreCurrentCostCentre :: Maybe VirtualSpBOffset -> FCode AbstractC
998 restoreCurrentCostCentre Nothing
1000 restoreCurrentCostCentre (Just b_slot)
1001 = getSpBRelOffset b_slot `thenFC` \ spb_rel ->
1002 freeBStkSlot b_slot `thenC`
1003 returnFC (CCallProfCCMacro SLIT("RESTORE_CCC") [CVal spb_rel CostCentreRep])
1004 -- we use the RESTORE_CCC macro, rather than just
1005 -- assigning into CurCostCentre, in case RESTORE_CCC
1006 -- has some sanity-checking in it.
1010 %************************************************************************
1012 \subsection[CgCase-return-vec]{Building a return vector}
1014 %************************************************************************
1016 Build a return vector, and return a suitable label addressing
1020 mkReturnVector :: Unique
1022 -> [(ConTag, AbstractC)] -- Branch codes
1023 -> AbstractC -- Default case
1026 mkReturnVector uniq ty tagged_alt_absCs deflt_absC
1028 (return_vec_amode, vtbl_body) = case (ctrlReturnConvAlg spec_tycon) of {
1030 UnvectoredReturn _ ->
1031 (CUnVecLbl ret_label vtbl_label,
1032 absC (CRetUnVector vtbl_label
1033 (CLabelledCode ret_label
1034 (mkAlgAltsCSwitch (CReg TagReg)
1037 VectoredReturn table_size ->
1038 (CLbl vtbl_label DataPtrRep,
1039 absC (CRetVector vtbl_label
1040 -- must restore cc before each alt, if required
1041 (map mk_vector_entry [fIRST_TAG .. (table_size+fIRST_TAG-1)])
1044 -- Leave nops and comments in for now; they are eliminated
1045 -- lazily as it's printed.
1046 -- (case (nonemptyAbsC deflt_absC) of
1047 -- Nothing -> AbsCNop
1052 returnFC return_vec_amode
1056 (spec_tycon,_,_) = case (getDataSpecTyCon_maybe ty) of -- *must* be a real "data" type constructor
1058 Nothing -> pprError "ERROR: can't generate code for polymorphic case;\nprobably a mis-use of `seq' or `par';\nthe User's Guide has more details.\nOffending type: " (ppr PprDebug ty)
1060 vtbl_label = mkVecTblLabel uniq
1061 ret_label = mkReturnPtLabel uniq
1063 mk_vector_entry :: ConTag -> Maybe CAddrMode
1065 = case [ absC | (t, absC) <- tagged_alt_absCs, t == tag ] of
1067 [absC] -> Just (CCode absC)
1068 _ -> panic "mkReturnVector: too many"
1071 %************************************************************************
1073 \subsection[CgCase-utils]{Utilities for handling case expressions}
1075 %************************************************************************
1077 @possibleHeapCheck@ tests a flag passed in to decide whether to
1078 do a heap check or not.
1081 possibleHeapCheck :: GCFlag -> [MagicId] -> Bool -> Code -> Code
1083 possibleHeapCheck GCMayHappen regs node_reqd code = heapCheck regs node_reqd code
1084 possibleHeapCheck NoGC _ _ code = code
1087 Select a restricted set of registers based on a usage mask.
1090 selectByMask [] [] = []
1091 selectByMask (True:ms) (x:xs) = x : selectByMask ms xs
1092 selectByMask (False:ms) (x:xs) = selectByMask ms xs