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 getAppSpecDataTyConExpandingDicts, maybeAppSpecDataTyConExpandingDicts,
67 import Util ( sortLt, isIn, isn'tIn, zipEqual,
68 pprError, panic, assertPanic
74 = GCMayHappen -- The scrutinee may involve GC, so everything must be
75 -- tidy before the code for the scrutinee.
77 | NoGC -- The scrutinee is a primitive value, or a call to a
78 -- primitive op which does no GC. Hence the case can
79 -- be done inline, without tidying up first.
82 It is quite interesting to decide whether to put a heap-check
83 at the start of each alternative. Of course we certainly have
84 to do so if the case forces an evaluation, or if there is a primitive
85 op which can trigger GC.
87 A more interesting situation is this:
94 default -> !C!; ...C...
97 where \tr{!x!} indicates a possible heap-check point. The heap checks
98 in the alternatives {\em can} be omitted, in which case the topmost
99 heapcheck will take their worst case into account.
101 In favour of omitting \tr{!B!}, \tr{!C!}:
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
117 May do more allocation than reqd. This sometimes bites us
118 badly. For example, nfib (ha!) allocates about 30\% more space if the
119 worst-casing is done, because many many calls to nfib are leaf calls
120 which don't need to allocate anything.
122 This never hurts us if there is only one alternative.
126 *** NOT YET DONE *** The difficulty is that \tr{!B!}, \tr{!C!} need
127 to take account of what is live, and that includes all live volatile
128 variables, even if they also have stable analogues. Furthermore, the
129 stack pointers must be lined up properly so that GC sees tidy stacks.
130 If these things are done, then the heap checks can be done at \tr{!B!} and
131 \tr{!C!} without a full save-volatile-vars sequence.
142 Several special cases for primitive operations.
144 ******* TO DO TO DO: fix what follows
148 case (op x1 ... xn) of
151 where the type of the case scrutinee is a multi-constuctor algebraic type.
152 Then we simply compile code for
160 case (op x1 ... xn) of
164 where the type of the case scrutinee is a multi-constuctor algebraic type.
165 we just bomb out at the moment. It never happens in practice.
167 **** END OF TO DO TO DO
170 cgCase scrut@(StgPrim op args _) live_in_whole_case live_in_alts uniq
171 (StgAlgAlts _ alts (StgBindDefault id _ deflt_rhs))
172 = if not (null alts) then
173 panic "cgCase: case on PrimOp with default *and* alts\n"
174 -- For now, die if alts are non-empty
177 pprTrace "cgCase:prim app returning alg data type: bad code!" (ppr PprDebug scrut) $
178 -- See above TO DO TO DO
180 cgExpr (StgLet (StgNonRec id scrut_rhs) deflt_rhs)
182 scrut_rhs = StgRhsClosure useCurrentCostCentre stgArgOcc{-safe-} scrut_free_vars
184 scrut_free_vars = [ fv | StgVarArg fv <- args, not (toplevelishId fv) ]
190 cgCase (StgPrim op args _) live_in_whole_case live_in_alts uniq alts
191 | not (primOpCanTriggerGC op)
193 -- Get amodes for the arguments and results
194 getPrimOpArgAmodes op args `thenFC` \ arg_amodes ->
196 result_amodes = getPrimAppResultAmodes uniq alts
197 liveness_mask = panic "cgCase: liveness of non-GC-ing primop touched\n"
199 -- Perform the operation
200 getVolatileRegs live_in_alts `thenFC` \ vol_regs ->
202 absC (COpStmt result_amodes op
203 arg_amodes -- note: no liveness arg
204 liveness_mask vol_regs) `thenC`
206 -- Scrutinise the result
207 cgInlineAlts NoGC uniq alts
209 | otherwise -- *Can* trigger GC
210 = getPrimOpArgAmodes op args `thenFC` \ arg_amodes ->
212 -- Get amodes for the arguments and results, and assign to regs
213 -- (Can-trigger-gc primops guarantee to have their (nonRobust)
216 op_result_regs = assignPrimOpResultRegs op
218 op_result_amodes = map CReg op_result_regs
220 (op_arg_amodes, liveness_mask, arg_assts)
221 = makePrimOpArgsRobust op arg_amodes
223 liveness_arg = mkIntCLit liveness_mask
225 -- Tidy up in case GC happens...
227 -- Nota Bene the use of live_in_whole_case in nukeDeadBindings.
228 -- Reason: the arg_assts computed above may refer to some stack slots
229 -- which are not live in the alts. So we mustn't use those slots
230 -- to save volatile vars in!
231 nukeDeadBindings live_in_whole_case `thenC`
232 saveVolatileVars live_in_alts `thenFC` \ volatile_var_save_assts ->
234 getEndOfBlockInfo `thenFC` \ eob_info ->
235 forkEval eob_info nopC
236 (getAbsC (cgInlineAlts GCMayHappen uniq alts) `thenFC` \ abs_c ->
237 absC (CRetUnVector vtbl_label (CLabelledCode return_label abs_c))
239 returnFC (CaseAlts (CUnVecLbl return_label vtbl_label)
240 Nothing{-no semi-tagging-}))
241 `thenFC` \ new_eob_info ->
243 -- Record the continuation info
244 setEndOfBlockInfo new_eob_info (
246 -- Now "return" to the inline alternatives; this will get
247 -- compiled to a fall-through.
249 simultaneous_assts = arg_assts `mkAbsCStmts` volatile_var_save_assts
251 -- do_op_and_continue will be passed an amode for the continuation
252 do_op_and_continue sequel
253 = absC (COpStmt op_result_amodes
255 (pin_liveness op liveness_arg op_arg_amodes)
260 sequelToAmode sequel `thenFC` \ dest_amode ->
261 absC (CReturn dest_amode DirectReturn)
263 -- Note: we CJump even for algebraic data types,
264 -- because cgInlineAlts always generates code, never a
267 performReturn simultaneous_assts do_op_and_continue live_in_alts
270 -- for all PrimOps except ccalls, we pin the liveness info
271 -- on as the first "argument"
272 -- ToDo: un-duplicate?
274 pin_liveness (CCallOp _ _ _ _ _) _ args = args
275 pin_liveness other_op liveness_arg args
278 vtbl_label = mkVecTblLabel uniq
279 return_label = mkReturnPtLabel uniq
283 Another special case: scrutinising a primitive-typed variable. No
284 evaluation required. We don't save volatile variables, nor do we do a
285 heap-check in the alternatives. Instead, the heap usage of the
286 alternatives is worst-cased and passed upstream. This can result in
287 allocating more heap than strictly necessary, but it will sometimes
288 eliminate a heap check altogether.
291 cgCase (StgApp v [] _) live_in_whole_case live_in_alts uniq (StgPrimAlts ty alts deflt)
292 = getArgAmode v `thenFC` \ amode ->
293 cgPrimAltsGivenScrutinee NoGC amode alts deflt
296 Special case: scrutinising a non-primitive variable.
297 This can be done a little better than the general case, because
298 we can reuse/trim the stack slot holding the variable (if it is in one).
301 cgCase (StgApp (StgVarArg fun) args _ {-lvs must be same as live_in_alts-})
302 live_in_whole_case live_in_alts uniq alts@(StgAlgAlts _ _ _)
304 getCAddrModeAndInfo fun `thenFC` \ (fun_amode, lf_info) ->
305 getArgAmodes args `thenFC` \ arg_amodes ->
307 -- Squish the environment
308 nukeDeadBindings live_in_alts `thenC`
309 saveVolatileVarsAndRegs live_in_alts
310 `thenFC` \ (save_assts, alts_eob_info, maybe_cc_slot) ->
312 forkEval alts_eob_info
313 nopC (cgEvalAlts maybe_cc_slot uniq alts) `thenFC` \ scrut_eob_info ->
314 setEndOfBlockInfo scrut_eob_info (
315 tailCallBusiness fun fun_amode lf_info arg_amodes live_in_alts save_assts
320 Finally, here is the general case.
323 cgCase expr live_in_whole_case live_in_alts uniq alts
324 = -- Figure out what volatile variables to save
325 nukeDeadBindings live_in_whole_case `thenC`
326 saveVolatileVarsAndRegs live_in_alts
327 `thenFC` \ (save_assts, alts_eob_info, maybe_cc_slot) ->
329 -- Save those variables right now!
330 absC save_assts `thenC`
332 forkEval alts_eob_info
333 (nukeDeadBindings live_in_alts)
334 (cgEvalAlts maybe_cc_slot uniq alts) `thenFC` \ scrut_eob_info ->
336 setEndOfBlockInfo scrut_eob_info (cgExpr expr)
339 %************************************************************************
341 \subsection[CgCase-primops]{Primitive applications}
343 %************************************************************************
345 Get result amodes for a primitive operation, in the case wher GC can't happen.
346 The amodes are returned in canonical order, ready for the prim-op!
348 Alg case: temporaries named as in the alternatives,
349 plus (CTemp u) for the tag (if needed)
352 This is all disgusting, because these amodes must be consistent with those
353 invented by CgAlgAlts.
356 getPrimAppResultAmodes
363 -- If there's an StgBindDefault which does use the bound
364 -- variable, then we can only handle it if the type involved is
365 -- an enumeration type. That's important in the case
371 -- The only reason for the restriction to *enumeration* types is our
372 -- inability to invent suitable temporaries to hold the results;
373 -- Elaborating the CTemp addr mode to have a second uniq field
374 -- (which would simply count from 1) would solve the problem.
375 -- Anyway, cgInlineAlts is now capable of handling all cases;
376 -- it's only this function which is being wimpish.
378 getPrimAppResultAmodes uniq (StgAlgAlts ty alts (StgBindDefault _ True {- used -} _))
379 | isEnumerationTyCon spec_tycon = [tag_amode]
380 | otherwise = panic "getPrimAppResultAmodes: non-enumeration algebraic alternatives with default"
382 -- A temporary variable to hold the tag; this is unaffected by GC because
383 -- the heap-checks in the branches occur after the switch
384 tag_amode = CTemp uniq IntRep
385 (spec_tycon, _, _) = getAppSpecDataTyConExpandingDicts ty
387 getPrimAppResultAmodes uniq (StgAlgAlts ty alts other_default)
388 -- Default is either StgNoDefault or StgBindDefault with unused binder
390 [_] -> arg_amodes -- No need for a tag
391 other -> tag_amode : arg_amodes
393 -- A temporary variable to hold the tag; this is unaffected by GC because
394 -- the heap-checks in the branches occur after the switch
395 tag_amode = CTemp uniq IntRep
397 -- Sort alternatives into canonical order; there must be a complete
398 -- set because there's no default case.
399 sorted_alts = sortLt lt alts
400 (con1,_,_,_) `lt` (con2,_,_,_) = dataConTag con1 < dataConTag con2
402 arg_amodes :: [CAddrMode]
404 -- Turn them into amodes
405 arg_amodes = concat (map mk_amodes sorted_alts)
406 mk_amodes (con, args, use_mask, rhs)
407 = [ CTemp (uniqueOf arg) (idPrimRep arg) | arg <- args ]
410 The situation is simpler for primitive
411 results, because there is only one!
414 getPrimAppResultAmodes uniq (StgPrimAlts ty _ _)
415 = [CTemp uniq (typePrimRep ty)]
419 %************************************************************************
421 \subsection[CgCase-alts]{Alternatives}
423 %************************************************************************
425 @cgEvalAlts@ returns an addressing mode for a continuation for the
426 alternatives of a @case@, used in a context when there
427 is some evaluation to be done.
430 cgEvalAlts :: Maybe VirtualSpBOffset -- Offset of cost-centre to be restored, if any
433 -> FCode Sequel -- Any addr modes inside are guaranteed to be a label
434 -- so that we can duplicate it without risk of
437 cgEvalAlts cc_slot uniq (StgAlgAlts ty alts deflt)
438 = -- Generate the instruction to restore cost centre, if any
439 restoreCurrentCostCentre cc_slot `thenFC` \ cc_restore ->
441 -- Generate sequel info for use downstream
442 -- At the moment, we only do it if the type is vector-returnable.
443 -- Reason: if not, then it costs extra to label the
444 -- alternatives, because we'd get return code like:
446 -- switch TagReg { 0 : JMP(alt_1); 1 : JMP(alt_2) ..etc }
448 -- which is worse than having the alt code in the switch statement
451 (spec_tycon, _, _) = getAppSpecDataTyConExpandingDicts ty
454 = case ctrlReturnConvAlg spec_tycon of
455 VectoredReturn _ -> True
459 = if not use_labelled_alts then
460 Nothing -- no semi-tagging info
462 cgSemiTaggedAlts uniq alts deflt -- Just <something>
464 cgAlgAlts GCMayHappen uniq cc_restore use_labelled_alts ty alts deflt
465 `thenFC` \ (tagged_alt_absCs, deflt_absC) ->
467 mkReturnVector uniq ty tagged_alt_absCs deflt_absC `thenFC` \ return_vec ->
469 returnFC (CaseAlts return_vec semi_tagged_stuff)
471 cgEvalAlts cc_slot uniq (StgPrimAlts ty alts deflt)
472 = -- Generate the instruction to restore cost centre, if any
473 restoreCurrentCostCentre cc_slot `thenFC` \ cc_restore ->
475 -- Generate the switch
476 getAbsC (cgPrimAlts GCMayHappen uniq ty alts deflt) `thenFC` \ abs_c ->
478 -- Generate the labelled block, starting with restore-cost-centre
479 absC (CRetUnVector vtbl_label
480 (CLabelledCode return_label (cc_restore `mkAbsCStmts` abs_c)))
482 -- Return an amode for the block
483 returnFC (CaseAlts (CUnVecLbl return_label vtbl_label) Nothing{-no semi-tagging-})
485 vtbl_label = mkVecTblLabel uniq
486 return_label = mkReturnPtLabel uniq
491 cgInlineAlts :: GCFlag -> Unique
496 First case: algebraic case, exactly one alternative, no default.
497 In this case the primitive op will not have set a temporary to the
498 tag, so we shouldn't generate a switch statment. Instead we just
502 cgInlineAlts gc_flag uniq (StgAlgAlts ty [alt@(con,args,use_mask,rhs)] StgNoDefault)
503 = cgAlgAltRhs gc_flag con args use_mask rhs
506 Second case: algebraic case, several alternatives.
507 Tag is held in a temporary.
510 cgInlineAlts gc_flag uniq (StgAlgAlts ty alts deflt)
511 = cgAlgAlts gc_flag uniq AbsCNop{-restore_cc-} False{-no semi-tagging-}
512 ty alts deflt `thenFC` \ (tagged_alts, deflt_c) ->
515 absC (mkAlgAltsCSwitch tag_amode tagged_alts deflt_c)
517 -- A temporary variable to hold the tag; this is unaffected by GC because
518 -- the heap-checks in the branches occur after the switch
519 tag_amode = CTemp uniq IntRep
522 Third (real) case: primitive result type.
525 cgInlineAlts gc_flag uniq (StgPrimAlts ty alts deflt)
526 = cgPrimAlts gc_flag uniq ty alts deflt
530 %************************************************************************
532 \subsection[CgCase-alg-alts]{Algebraic alternatives}
534 %************************************************************************
536 In @cgAlgAlts@, none of the binders in the alternatives are
537 assumed to be yet bound.
542 -> AbstractC -- Restore-cost-centre instruction
543 -> Bool -- True <=> branches must be labelled
544 -> Type -- From the case statement
545 -> [(Id, [Id], [Bool], StgExpr)] -- The alternatives
546 -> StgCaseDefault -- The default
547 -> FCode ([(ConTag, AbstractC)], -- The branches
548 AbstractC -- The default case
552 The case with a default which has a binder is different. We need to
553 pick all the constructors which aren't handled explicitly by an
554 alternative, and which return their results in registers, allocate
555 them explicitly in the heap, and jump to a join point for the default
558 OLD: All of this only works if a heap-check is required anyway, because
559 otherwise it isn't safe to allocate.
561 NEW (July 94): now false! It should work regardless of gc_flag,
562 because of the extra_branches argument now added to forkAlts.
564 We put a heap-check at the join point, for the benefit of constructors
565 which don't need to do allocation. This means that ones which do need
566 to allocate may end up doing two heap-checks; but that's just too bad.
567 (We'd need two join labels otherwise. ToDo.)
569 It's all pretty turgid anyway.
572 cgAlgAlts gc_flag uniq restore_cc semi_tagging
573 ty alts deflt@(StgBindDefault binder True{-used-} _)
575 extra_branches :: [FCode (ConTag, AbstractC)]
576 extra_branches = catMaybes (map mk_extra_branch default_cons)
578 must_label_default = semi_tagging || not (null extra_branches)
580 forkAlts (map (cgAlgAlt gc_flag uniq restore_cc semi_tagging) alts)
582 (cgAlgDefault gc_flag uniq restore_cc must_label_default deflt)
585 default_join_lbl = mkDefaultLabel uniq
586 jump_instruction = CJump (CLbl default_join_lbl CodePtrRep)
588 (spec_tycon, _, spec_cons) = getAppSpecDataTyConExpandingDicts ty
590 alt_cons = [ con | (con,_,_,_) <- alts ]
592 default_cons = [ spec_con | spec_con <- spec_cons, -- In this type
593 spec_con `not_elem` alt_cons ] -- Not handled explicitly
595 not_elem = isn'tIn "cgAlgAlts"
597 -- (mk_extra_branch con) returns the a maybe for the extra branch for con.
598 -- The "maybe" is because con may return in heap, in which case there is
599 -- nothing to do. Otherwise, we have a special case for a nullary constructor,
600 -- but in the general case we do an allocation and heap-check.
602 mk_extra_branch :: DataCon -> (Maybe (FCode (ConTag, AbstractC)))
605 = ASSERT(isDataCon con)
606 case dataReturnConvAlg con of
607 ReturnInHeap -> Nothing
608 ReturnInRegs rs -> Just (getAbsC (alloc_code rs) `thenFC` \ abs_c ->
609 returnFC (tag, abs_c)
612 lf_info = mkConLFInfo con
614 closure_lbl = mkClosureLabel con
616 -- alloc_code generates code to allocate constructor con, whose args are
617 -- in the arguments to alloc_code, assigning the result to Node.
618 alloc_code :: [MagicId] -> Code
621 = possibleHeapCheck gc_flag regs False (
622 buildDynCon binder useCurrentCostCentre con
623 (map CReg regs) (all zero_size regs)
625 idInfoToAmode PtrRep idinfo `thenFC` \ amode ->
627 absC (CAssign (CReg node) amode) `thenC`
628 absC jump_instruction
631 zero_size reg = getPrimRepSize (magicIdPrimRep reg) == 0
634 Now comes the general case
637 cgAlgAlts gc_flag uniq restore_cc must_label_branches ty alts deflt
638 {- The deflt is either StgNoDefault or a BindDefault which doesn't use the binder -}
639 = forkAlts (map (cgAlgAlt gc_flag uniq restore_cc must_label_branches) alts)
640 [{- No "extra branches" -}]
641 (cgAlgDefault gc_flag uniq restore_cc must_label_branches deflt)
645 cgAlgDefault :: GCFlag
646 -> Unique -> AbstractC -> Bool -- turgid state...
647 -> StgCaseDefault -- input
648 -> FCode AbstractC -- output
650 cgAlgDefault gc_flag uniq restore_cc must_label_branch
654 cgAlgDefault gc_flag uniq restore_cc must_label_branch
655 (StgBindDefault _ False{-binder not used-} rhs)
657 = getAbsC (absC restore_cc `thenC`
658 possibleHeapCheck gc_flag [] False (cgExpr rhs)) `thenFC` \ abs_c ->
660 final_abs_c | must_label_branch = CJump (CLabelledCode lbl abs_c)
665 lbl = mkDefaultLabel uniq
668 cgAlgDefault gc_flag uniq restore_cc must_label_branch
669 (StgBindDefault binder True{-binder used-} rhs)
671 = -- We have arranged that Node points to the thing, even
672 -- even if we return in registers
673 bindNewToReg binder node mkLFArgument `thenC`
674 getAbsC (absC restore_cc `thenC`
675 possibleHeapCheck gc_flag [node] False (cgExpr rhs)
676 -- Node is live, but doesn't need to point at the thing itself;
677 -- it's ok for Node to point to an indirection or FETCH_ME
678 -- Hence no need to re-enter Node.
679 ) `thenFC` \ abs_c ->
682 final_abs_c | must_label_branch = CJump (CLabelledCode lbl abs_c)
687 lbl = mkDefaultLabel uniq
691 -> Unique -> AbstractC -> Bool -- turgid state
692 -> (Id, [Id], [Bool], StgExpr)
693 -> FCode (ConTag, AbstractC)
695 cgAlgAlt gc_flag uniq restore_cc must_label_branch (con, args, use_mask, rhs)
696 = getAbsC (absC restore_cc `thenC`
697 cgAlgAltRhs gc_flag con args use_mask rhs) `thenFC` \ abs_c ->
699 final_abs_c | must_label_branch = CJump (CLabelledCode lbl abs_c)
702 returnFC (tag, final_abs_c)
705 lbl = mkAltLabel uniq tag
707 cgAlgAltRhs :: GCFlag -> Id -> [Id] -> [Bool] -> StgExpr -> Code
709 cgAlgAltRhs gc_flag con args use_mask rhs
711 (live_regs, node_reqd)
712 = case (dataReturnConvAlg con) of
713 ReturnInHeap -> ([], True)
714 ReturnInRegs regs -> ([reg | (reg,True) <- zipEqual "cgAlgAltRhs" regs use_mask], False)
715 -- Pick the live registers using the use_mask
716 -- Doing so is IMPORTANT, because with semi-tagging
717 -- enabled only the live registers will have valid
720 possibleHeapCheck gc_flag live_regs node_reqd (
722 NoGC -> mapFCs bindNewToTemp args `thenFC` \ _ ->
724 GCMayHappen -> bindConArgs con args
730 %************************************************************************
732 \subsection[CgCase-semi-tagged-alts]{The code to deal with sem-tagging}
734 %************************************************************************
736 Turgid-but-non-monadic code to conjure up the required info from
737 algebraic case alternatives for semi-tagging.
740 cgSemiTaggedAlts :: Unique
741 -> [(Id, [Id], [Bool], StgExpr)]
742 -> GenStgCaseDefault Id Id
745 cgSemiTaggedAlts uniq alts deflt
746 = Just (map st_alt alts, st_deflt deflt)
748 st_deflt StgNoDefault = Nothing
750 st_deflt (StgBindDefault binder binder_used _)
751 = Just (if binder_used then Just binder else Nothing,
752 (CCallProfCtrMacro SLIT("RET_SEMI_BY_DEFAULT") [], -- ToDo: monadise?
756 st_alt (con, args, use_mask, _)
757 = case (dataReturnConvAlg con) of
760 -- Ha! Nothing to do; Node already points to the thing
762 (CCallProfCtrMacro SLIT("RET_SEMI_IN_HEAP") -- ToDo: monadise?
763 [mkIntCLit (length args)], -- how big the thing in the heap is
768 -- We have to load the live registers from the constructor
769 -- pointed to by Node.
771 (_, regs_w_offsets) = layOutDynCon con magicIdPrimRep regs
773 used_regs = selectByMask use_mask regs
775 used_regs_w_offsets = [ ro | ro@(reg,offset) <- regs_w_offsets,
776 reg `is_elem` used_regs]
778 is_elem = isIn "cgSemiTaggedAlts"
782 CCallProfCtrMacro SLIT("RET_SEMI_IN_REGS") -- ToDo: macroise?
783 [mkIntCLit (length regs_w_offsets),
784 mkIntCLit (length used_regs_w_offsets)],
785 CSimultaneous (mkAbstractCs (map move_to_reg used_regs_w_offsets))],
788 con_tag = dataConTag con
789 join_label = mkAltLabel uniq con_tag
791 move_to_reg :: (MagicId, VirtualHeapOffset {-from Node-}) -> AbstractC
792 move_to_reg (reg, offset)
793 = CAssign (CReg reg) (CVal (NodeRel offset) (magicIdPrimRep reg))
796 %************************************************************************
798 \subsection[CgCase-prim-alts]{Primitive alternatives}
800 %************************************************************************
802 @cgPrimAlts@ generates a suitable @CSwitch@ for dealing with the
803 alternatives of a primitive @case@, given an addressing mode for the
804 thing to scrutinise. It also keeps track of the maximum stack depth
805 encountered down any branch.
807 As usual, no binders in the alternatives are yet bound.
813 -> [(Literal, StgExpr)] -- Alternatives
814 -> StgCaseDefault -- Default
817 cgPrimAlts gc_flag uniq ty alts deflt
818 = cgPrimAltsGivenScrutinee gc_flag scrutinee alts deflt
820 -- A temporary variable, or standard register, to hold the result
821 scrutinee = case gc_flag of
822 NoGC -> CTemp uniq kind
823 GCMayHappen -> CReg (dataReturnConvPrim kind)
825 kind = typePrimRep ty
828 cgPrimAltsGivenScrutinee gc_flag scrutinee alts deflt
829 = forkAlts (map (cgPrimAlt gc_flag) alts)
830 [{- No "extra branches" -}]
831 (cgPrimDefault gc_flag scrutinee deflt) `thenFC` \ (alt_absCs, deflt_absC) ->
832 absC (CSwitch scrutinee alt_absCs deflt_absC)
833 -- CSwitch does sensible things with one or zero alternatives
837 -> (Literal, StgExpr) -- The alternative
838 -> FCode (Literal, AbstractC) -- Its compiled form
840 cgPrimAlt gc_flag (lit, rhs)
841 = getAbsC rhs_code `thenFC` \ absC ->
844 rhs_code = possibleHeapCheck gc_flag [] False (cgExpr rhs )
846 cgPrimDefault :: GCFlag
847 -> CAddrMode -- Scrutinee
851 cgPrimDefault gc_flag scrutinee StgNoDefault
852 = panic "cgPrimDefault: No default in prim case"
854 cgPrimDefault gc_flag scrutinee (StgBindDefault _ False{-binder not used-} rhs)
855 = getAbsC (possibleHeapCheck gc_flag [] False (cgExpr rhs ))
857 cgPrimDefault gc_flag scrutinee (StgBindDefault binder True{-used-} rhs)
858 = getAbsC (possibleHeapCheck gc_flag regs False rhs_code)
860 regs = if isFollowableRep (getAmodeRep scrutinee) then
863 rhs_code = bindNewPrimToAmode binder scrutinee `thenC`
868 %************************************************************************
870 \subsection[CgCase-tidy]{Code for tidying up prior to an eval}
872 %************************************************************************
875 saveVolatileVarsAndRegs
876 :: StgLiveVars -- Vars which should be made safe
877 -> FCode (AbstractC, -- Assignments to do the saves
878 EndOfBlockInfo, -- New sequel, recording where the return
880 Maybe VirtualSpBOffset) -- Slot for current cost centre
883 saveVolatileVarsAndRegs vars
884 = saveVolatileVars vars `thenFC` \ var_saves ->
885 saveCurrentCostCentre `thenFC` \ (maybe_cc_slot, cc_save) ->
886 saveReturnAddress `thenFC` \ (new_eob_info, ret_save) ->
887 returnFC (mkAbstractCs [var_saves, cc_save, ret_save],
892 saveVolatileVars :: StgLiveVars -- Vars which should be made safe
893 -> FCode AbstractC -- Assignments to to the saves
895 saveVolatileVars vars
896 = save_em (idSetToList vars)
898 save_em [] = returnFC AbsCNop
901 = getCAddrModeIfVolatile var `thenFC` \ v ->
903 Nothing -> save_em vars -- Non-volatile, so carry on
906 Just vol_amode -> -- Aha! It's volatile
907 save_var var vol_amode `thenFC` \ abs_c ->
908 save_em vars `thenFC` \ abs_cs ->
909 returnFC (abs_c `mkAbsCStmts` abs_cs)
911 save_var var vol_amode
912 | isFollowableRep kind
913 = allocAStack `thenFC` \ a_slot ->
914 rebindToAStack var a_slot `thenC`
915 getSpARelOffset a_slot `thenFC` \ spa_rel ->
916 returnFC (CAssign (CVal spa_rel kind) vol_amode)
918 = allocBStack (getPrimRepSize kind) `thenFC` \ b_slot ->
919 rebindToBStack var b_slot `thenC`
920 getSpBRelOffset b_slot `thenFC` \ spb_rel ->
921 returnFC (CAssign (CVal spb_rel kind) vol_amode)
923 kind = getAmodeRep vol_amode
925 saveReturnAddress :: FCode (EndOfBlockInfo, AbstractC)
927 = getEndOfBlockInfo `thenFC` \ eob_info@(EndOfBlockInfo vA vB sequel) ->
929 -- See if it is volatile
931 InRetReg -> -- Yes, it's volatile
932 allocBStack retPrimRepSize `thenFC` \ b_slot ->
933 getSpBRelOffset b_slot `thenFC` \ spb_rel ->
935 returnFC (EndOfBlockInfo vA vB (OnStack b_slot),
936 CAssign (CVal spb_rel RetRep) (CReg RetReg))
938 UpdateCode _ -> -- It's non-volatile all right, but we still need
939 -- to allocate a B-stack slot for it, *solely* to make
940 -- sure that update frames for different values do not
941 -- appear adjacent on the B stack. This makes sure
942 -- that B-stack squeezing works ok.
944 allocBStack retPrimRepSize `thenFC` \ b_slot ->
945 returnFC (eob_info, AbsCNop)
947 other -> -- No, it's non-volatile, so do nothing
948 returnFC (eob_info, AbsCNop)
951 Note about B-stack squeezing. Consider the following:`
953 y = [...] \u [] -> ...
954 x = [y] \u [] -> case y of (a,b) -> a
956 The code for x will push an update frame, and then enter y. The code
957 for y will push another update frame. If the B-stack-squeezer then
958 wakes up, it will see two update frames right on top of each other,
959 and will combine them. This is WRONG, of course, because x's value is
962 The fix implemented above makes sure that we allocate an (unused)
963 B-stack slot before entering y. You can think of this as holding the
964 saved value of RetAddr, which (after pushing x's update frame will be
965 some update code ptr). The compiler is clever enough to load the
966 static update code ptr into RetAddr before entering ~a~, but the slot
967 is still there to separate the update frames.
969 When we save the current cost centre (which is done for lexical
970 scoping), we allocate a free B-stack location, and return (a)~the
971 virtual offset of the location, to pass on to the alternatives, and
972 (b)~the assignment to do the save (just as for @saveVolatileVars@).
975 saveCurrentCostCentre ::
976 FCode (Maybe VirtualSpBOffset, -- Where we decide to store it
977 -- Nothing if not lexical CCs
978 AbstractC) -- Assignment to save it
979 -- AbsCNop if not lexical CCs
981 saveCurrentCostCentre
983 doing_profiling = opt_SccProfilingOn
985 if not doing_profiling then
986 returnFC (Nothing, AbsCNop)
988 allocBStack (getPrimRepSize CostCentreRep) `thenFC` \ b_slot ->
989 getSpBRelOffset b_slot `thenFC` \ spb_rel ->
990 returnFC (Just b_slot,
991 CAssign (CVal spb_rel CostCentreRep) (CReg CurCostCentre))
993 restoreCurrentCostCentre :: Maybe VirtualSpBOffset -> FCode AbstractC
995 restoreCurrentCostCentre Nothing
997 restoreCurrentCostCentre (Just b_slot)
998 = getSpBRelOffset b_slot `thenFC` \ spb_rel ->
999 freeBStkSlot b_slot `thenC`
1000 returnFC (CCallProfCCMacro SLIT("RESTORE_CCC") [CVal spb_rel CostCentreRep])
1001 -- we use the RESTORE_CCC macro, rather than just
1002 -- assigning into CurCostCentre, in case RESTORE_CCC
1003 -- has some sanity-checking in it.
1007 %************************************************************************
1009 \subsection[CgCase-return-vec]{Building a return vector}
1011 %************************************************************************
1013 Build a return vector, and return a suitable label addressing
1017 mkReturnVector :: Unique
1019 -> [(ConTag, AbstractC)] -- Branch codes
1020 -> AbstractC -- Default case
1023 mkReturnVector uniq ty tagged_alt_absCs deflt_absC
1025 (return_vec_amode, vtbl_body) = case (ctrlReturnConvAlg spec_tycon) of {
1027 UnvectoredReturn _ ->
1028 (CUnVecLbl ret_label vtbl_label,
1029 absC (CRetUnVector vtbl_label
1030 (CLabelledCode ret_label
1031 (mkAlgAltsCSwitch (CReg TagReg)
1034 VectoredReturn table_size ->
1035 (CLbl vtbl_label DataPtrRep,
1036 absC (CRetVector vtbl_label
1037 -- must restore cc before each alt, if required
1038 (map mk_vector_entry [fIRST_TAG .. (table_size+fIRST_TAG-1)])
1041 -- Leave nops and comments in for now; they are eliminated
1042 -- lazily as it's printed.
1043 -- (case (nonemptyAbsC deflt_absC) of
1044 -- Nothing -> AbsCNop
1049 returnFC return_vec_amode
1053 (spec_tycon,_,_) = case (maybeAppSpecDataTyConExpandingDicts ty) of -- *must* be a real "data" type constructor
1055 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)
1057 vtbl_label = mkVecTblLabel uniq
1058 ret_label = mkReturnPtLabel uniq
1060 mk_vector_entry :: ConTag -> Maybe CAddrMode
1062 = case [ absC | (t, absC) <- tagged_alt_absCs, t == tag ] of
1064 [absC] -> Just (CCode absC)
1065 _ -> panic "mkReturnVector: too many"
1068 %************************************************************************
1070 \subsection[CgCase-utils]{Utilities for handling case expressions}
1072 %************************************************************************
1074 @possibleHeapCheck@ tests a flag passed in to decide whether to
1075 do a heap check or not.
1078 possibleHeapCheck :: GCFlag -> [MagicId] -> Bool -> Code -> Code
1080 possibleHeapCheck GCMayHappen regs node_reqd code = heapCheck regs node_reqd code
1081 possibleHeapCheck NoGC _ _ code = code
1084 Select a restricted set of registers based on a usage mask.
1087 selectByMask [] [] = []
1088 selectByMask (True:ms) (x:xs) = x : selectByMask ms xs
1089 selectByMask (False:ms) (x:xs) = selectByMask ms xs