2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
4 %********************************************************
6 \section[CgCase]{Converting @StgCase@ expressions}
8 %********************************************************
11 #include "HsVersions.h"
15 saveVolatileVarsAndRegs,
17 -- and to make the interface self-sufficient...
18 StgExpr, Id, StgCaseAlternatives, CgState
21 IMPORT_Trace -- ToDo: rm (debugging)
29 import AbsPrel ( PrimOp(..), primOpCanTriggerGC
30 IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp)
31 IF_ATTACK_PRAGMAS(COMMA pprPrimOp)
33 import AbsUniType ( kindFromType, getTyConDataCons,
34 getUniDataSpecTyCon, getUniDataSpecTyCon_maybe,
38 import CgBindery -- all of it
39 import CgCon ( buildDynCon, bindConArgs )
40 import CgExpr ( cgExpr, getPrimOpArgAmodes )
41 import CgHeapery ( heapCheck )
42 import CgRetConv -- lots of stuff
43 import CgStackery -- plenty
44 import CgTailCall ( tailCallBusiness, performReturn )
45 import CgUsages -- and even more
46 import CLabelInfo -- bunches of things...
47 import ClosureInfo {-( blackHoleClosureInfo, mkConLFInfo, mkLFArgument,
50 import CmdLineOpts ( GlobalSwitch(..) )
51 import CostCentre ( useCurrentCostCentre, CostCentre )
52 import BasicLit ( kindOfBasicLit )
53 import Id ( getDataConTag, getIdKind, fIRST_TAG, isDataCon,
54 toplevelishId, getInstantiatedDataConSig,
55 ConTag(..), DataCon(..)
57 import Maybes ( catMaybes, Maybe(..) )
58 import PrimKind ( getKindSize, isFollowableKind, retKindSize, PrimKind(..) )
59 import UniqSet -- ( uniqSetToList, UniqSet(..) )
65 = GCMayHappen -- The scrutinee may involve GC, so everything must be
66 -- tidy before the code for the scrutinee.
68 | NoGC -- The scrutinee is a primitive value, or a call to a
69 -- primitive op which does no GC. Hence the case can
70 -- be done inline, without tidying up first.
73 It is quite interesting to decide whether to put a heap-check
74 at the start of each alternative. Of course we certainly have
75 to do so if the case forces an evaluation, or if there is a primitive
76 op which can trigger GC.
78 A more interesting situation is this:
85 default -> !C!; ...C...
88 where \tr{!x!} indicates a possible heap-check point. The heap checks
89 in the alternatives {\em can} be omitted, in which case the topmost
90 heapcheck will take their worst case into account.
92 In favour of omitting \tr{!B!}, \tr{!C!}:
96 {\em May} save a heap overflow test,
97 if ...A... allocates anything. The other advantage
98 of this is that we can use relative addressing
99 from a single Hp to get at all the closures so allocated.
101 No need to save volatile vars etc across the case
108 May do more allocation than reqd. This sometimes bites us
109 badly. For example, nfib (ha!) allocates about 30\% more space if the
110 worst-casing is done, because many many calls to nfib are leaf calls
111 which don't need to allocate anything.
113 This never hurts us if there is only one alternative.
117 *** NOT YET DONE *** The difficulty is that \tr{!B!}, \tr{!C!} need
118 to take account of what is live, and that includes all live volatile
119 variables, even if they also have stable analogues. Furthermore, the
120 stack pointers must be lined up properly so that GC sees tidy stacks.
121 If these things are done, then the heap checks can be done at \tr{!B!} and
122 \tr{!C!} without a full save-volatile-vars sequence.
125 cgCase :: PlainStgExpr
129 -> PlainStgCaseAlternatives
133 Several special cases for primitive operations.
135 ******* TO DO TO DO: fix what follows
139 case (op x1 ... xn) of
142 where the type of the case scrutinee is a multi-constuctor algebraic type.
143 Then we simply compile code for
151 case (op x1 ... xn) of
155 where the type of the case scrutinee is a multi-constuctor algebraic type.
156 we just bomb out at the moment. It never happens in practice.
158 **** END OF TO DO TO DO
161 cgCase scrut@(StgPrimApp op args _) live_in_whole_case live_in_alts uniq
162 (StgAlgAlts _ alts (StgBindDefault id _ deflt_rhs))
163 = if not (null alts) then
164 panic "cgCase: case on PrimOp with default *and* alts\n"
165 -- For now, die if alts are non-empty
168 pprTrace "cgCase:prim app returning alg data type: bad code!" (ppr PprDebug scrut) $
169 -- See above TO DO TO DO
171 cgExpr (StgLet (StgNonRec id scrut_rhs) deflt_rhs)
173 scrut_rhs = StgRhsClosure useCurrentCostCentre stgArgOcc{-safe-} scrut_free_vars
175 scrut_free_vars = [ fv | StgVarAtom fv <- args, not (toplevelishId fv) ]
181 cgCase (StgPrimApp op args _) live_in_whole_case live_in_alts uniq alts
182 | not (primOpCanTriggerGC op)
184 -- Get amodes for the arguments and results
185 getPrimOpArgAmodes op args `thenFC` \ arg_amodes ->
187 result_amodes = getPrimAppResultAmodes uniq alts
188 liveness_mask = panic "cgCase: liveness of non-GC-ing primop touched\n"
190 -- Perform the operation
191 getVolatileRegs live_in_alts `thenFC` \ vol_regs ->
193 absC (COpStmt result_amodes op
194 arg_amodes -- note: no liveness arg
195 liveness_mask vol_regs) `thenC`
197 -- Scrutinise the result
198 cgInlineAlts NoGC uniq alts
200 | otherwise -- *Can* trigger GC
201 = getPrimOpArgAmodes op args `thenFC` \ arg_amodes ->
202 --NO: getIntSwitchChkrC `thenFC` \ isw_chkr ->
204 -- Get amodes for the arguments and results, and assign to regs
205 -- (Can-trigger-gc primops guarantee to have their (nonRobust)
208 op_result_regs = assignPrimOpResultRegs {-NO:isw_chkr-} op
210 op_result_amodes = map CReg op_result_regs
212 (op_arg_amodes, liveness_mask, arg_assts)
213 = makePrimOpArgsRobust {-NO:isw_chkr-} op arg_amodes
215 liveness_arg = mkIntCLit liveness_mask
217 -- Tidy up in case GC happens...
219 -- Nota Bene the use of live_in_whole_case in nukeDeadBindings.
220 -- Reason: the arg_assts computed above may refer to some stack slots
221 -- which are not live in the alts. So we mustn't use those slots
222 -- to save volatile vars in!
223 nukeDeadBindings live_in_whole_case `thenC`
224 saveVolatileVars live_in_alts `thenFC` \ volatile_var_save_assts ->
226 getEndOfBlockInfo `thenFC` \ eob_info ->
227 forkEval eob_info nopC
228 (getAbsC (cgInlineAlts GCMayHappen uniq alts) `thenFC` \ abs_c ->
229 absC (CRetUnVector vtbl_label (CLabelledCode return_label abs_c))
231 returnFC (CaseAlts (CUnVecLbl return_label vtbl_label)
232 Nothing{-no semi-tagging-}))
233 `thenFC` \ new_eob_info ->
235 -- Record the continuation info
236 setEndOfBlockInfo new_eob_info (
238 -- Now "return" to the inline alternatives; this will get
239 -- compiled to a fall-through.
241 simultaneous_assts = arg_assts `mkAbsCStmts` volatile_var_save_assts
243 -- do_op_and_continue will be passed an amode for the continuation
244 do_op_and_continue sequel
245 = absC (COpStmt op_result_amodes
247 (pin_liveness op liveness_arg op_arg_amodes)
252 sequelToAmode sequel `thenFC` \ dest_amode ->
253 absC (CReturn dest_amode DirectReturn)
255 -- Note: we CJump even for algebraic data types,
256 -- because cgInlineAlts always generates code, never a
259 performReturn simultaneous_assts do_op_and_continue live_in_alts
262 -- for all PrimOps except ccalls, we pin the liveness info
263 -- on as the first "argument"
264 -- ToDo: un-duplicate?
266 pin_liveness (CCallOp _ _ _ _ _) _ args = args
267 pin_liveness other_op liveness_arg args
270 vtbl_label = mkVecTblLabel uniq
271 return_label = mkReturnPtLabel uniq
275 Another special case: scrutinising a primitive-typed variable. No
276 evaluation required. We don't save volatile variables, nor do we do a
277 heap-check in the alternatives. Instead, the heap usage of the
278 alternatives is worst-cased and passed upstream. This can result in
279 allocating more heap than strictly necessary, but it will sometimes
280 eliminate a heap check altogether.
283 cgCase (StgApp v [] _) live_in_whole_case live_in_alts uniq (StgPrimAlts ty alts deflt)
284 = getAtomAmode v `thenFC` \ amode ->
285 cgPrimAltsGivenScrutinee NoGC amode alts deflt
288 Special case: scrutinising a non-primitive variable.
289 This can be done a little better than the general case, because
290 we can reuse/trim the stack slot holding the variable (if it is in one).
293 cgCase (StgApp (StgVarAtom fun) args _ {-lvs must be same as live_in_alts-})
294 live_in_whole_case live_in_alts uniq alts@(StgAlgAlts _ _ _)
296 getCAddrModeAndInfo fun `thenFC` \ (fun_amode, lf_info) ->
297 getAtomAmodes args `thenFC` \ arg_amodes ->
299 -- Squish the environment
300 nukeDeadBindings live_in_alts `thenC`
301 saveVolatileVarsAndRegs live_in_alts
302 `thenFC` \ (save_assts, alts_eob_info, maybe_cc_slot) ->
304 forkEval alts_eob_info
305 nopC (cgEvalAlts maybe_cc_slot uniq alts) `thenFC` \ scrut_eob_info ->
306 setEndOfBlockInfo scrut_eob_info (
307 tailCallBusiness fun fun_amode lf_info arg_amodes live_in_alts save_assts
312 Finally, here is the general case.
315 cgCase expr live_in_whole_case live_in_alts uniq alts
316 = -- Figure out what volatile variables to save
317 nukeDeadBindings live_in_whole_case `thenC`
318 saveVolatileVarsAndRegs live_in_alts
319 `thenFC` \ (save_assts, alts_eob_info, maybe_cc_slot) ->
321 -- Save those variables right now!
322 absC save_assts `thenC`
324 forkEval alts_eob_info
325 (nukeDeadBindings live_in_alts)
326 (cgEvalAlts maybe_cc_slot uniq alts) `thenFC` \ scrut_eob_info ->
328 setEndOfBlockInfo scrut_eob_info (cgExpr expr)
331 %************************************************************************
333 \subsection[CgCase-primops]{Primitive applications}
335 %************************************************************************
337 Get result amodes for a primitive operation, in the case wher GC can't happen.
338 The amodes are returned in canonical order, ready for the prim-op!
340 Alg case: temporaries named as in the alternatives,
341 plus (CTemp u) for the tag (if needed)
344 This is all disgusting, because these amodes must be consistent with those
345 invented by CgAlgAlts.
348 getPrimAppResultAmodes
350 -> PlainStgCaseAlternatives
355 -- If there's an StgBindDefault which does use the bound
356 -- variable, then we can only handle it if the type involved is
357 -- an enumeration type. That's important in the case
363 -- The only reason for the restriction to *enumeration* types is our
364 -- inability to invent suitable temporaries to hold the results;
365 -- Elaborating the CTemp addr mode to have a second uniq field
366 -- (which would simply count from 1) would solve the problem.
367 -- Anyway, cgInlineAlts is now capable of handling all cases;
368 -- it's only this function which is being wimpish.
370 getPrimAppResultAmodes uniq (StgAlgAlts ty alts (StgBindDefault _ True {- used -} _))
371 | isEnumerationTyCon spec_tycon = [tag_amode]
372 | otherwise = panic "getPrimAppResultAmodes: non-enumeration algebraic alternatives with default"
374 -- A temporary variable to hold the tag; this is unaffected by GC because
375 -- the heap-checks in the branches occur after the switch
376 tag_amode = CTemp uniq IntKind
377 (spec_tycon, _, _) = getUniDataSpecTyCon ty
379 getPrimAppResultAmodes uniq (StgAlgAlts ty alts other_default)
380 -- Default is either StgNoDefault or StgBindDefault with unused binder
382 [_] -> arg_amodes -- No need for a tag
383 other -> tag_amode : arg_amodes
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 IntKind
389 -- Sort alternatives into canonical order; there must be a complete
390 -- set because there's no default case.
391 sorted_alts = sortLt lt alts
392 (con1,_,_,_) `lt` (con2,_,_,_) = getDataConTag con1 < getDataConTag con2
394 arg_amodes :: [CAddrMode]
396 -- Turn them into amodes
397 arg_amodes = concat (map mk_amodes sorted_alts)
398 mk_amodes (con, args, use_mask, rhs)
399 = [ CTemp (getTheUnique arg) (getIdKind arg) | arg <- args ]
402 The situation is simpler for primitive
403 results, because there is only one!
406 getPrimAppResultAmodes uniq (StgPrimAlts ty _ _)
409 kind = kindFromType ty
413 %************************************************************************
415 \subsection[CgCase-alts]{Alternatives}
417 %************************************************************************
419 @cgEvalAlts@ returns an addressing mode for a continuation for the
420 alternatives of a @case@, used in a context when there
421 is some evaluation to be done.
424 cgEvalAlts :: Maybe VirtualSpBOffset -- Offset of cost-centre to be restored, if any
426 -> PlainStgCaseAlternatives
427 -> FCode Sequel -- Any addr modes inside are guaranteed to be a label
428 -- so that we can duplicate it without risk of
431 cgEvalAlts cc_slot uniq (StgAlgAlts ty alts deflt)
432 = -- Generate the instruction to restore cost centre, if any
433 restoreCurrentCostCentre cc_slot `thenFC` \ cc_restore ->
434 getIntSwitchChkrC `thenFC` \ isw_chkr ->
436 -- Generate sequel info for use downstream
437 -- At the moment, we only do it if the type is vector-returnable.
438 -- Reason: if not, then it costs extra to label the
439 -- alternatives, because we'd get return code like:
441 -- switch TagReg { 0 : JMP(alt_1); 1 : JMP(alt_2) ..etc }
443 -- which is worse than having the alt code in the switch statement
446 (spec_tycon, _, _) = getUniDataSpecTyCon ty
449 = case ctrlReturnConvAlg spec_tycon of
450 VectoredReturn _ -> True
454 = if not use_labelled_alts then
455 Nothing -- no semi-tagging info
457 cgSemiTaggedAlts isw_chkr uniq alts deflt -- Just <something>
459 cgAlgAlts GCMayHappen uniq cc_restore use_labelled_alts ty alts deflt
460 `thenFC` \ (tagged_alt_absCs, deflt_absC) ->
462 mkReturnVector uniq ty tagged_alt_absCs deflt_absC `thenFC` \ return_vec ->
464 returnFC (CaseAlts return_vec semi_tagged_stuff)
466 cgEvalAlts cc_slot uniq (StgPrimAlts ty alts deflt)
467 = -- Generate the instruction to restore cost centre, if any
468 restoreCurrentCostCentre cc_slot `thenFC` \ cc_restore ->
470 -- Generate the switch
471 getAbsC (cgPrimAlts GCMayHappen uniq ty alts deflt) `thenFC` \ abs_c ->
473 -- Generate the labelled block, starting with restore-cost-centre
474 absC (CRetUnVector vtbl_label
475 (CLabelledCode return_label (cc_restore `mkAbsCStmts` abs_c)))
477 -- Return an amode for the block
478 returnFC (CaseAlts (CUnVecLbl return_label vtbl_label) Nothing{-no semi-tagging-})
480 vtbl_label = mkVecTblLabel uniq
481 return_label = mkReturnPtLabel uniq
486 cgInlineAlts :: GCFlag -> Unique
487 -> PlainStgCaseAlternatives
491 First case: algebraic case, exactly one alternative, no default.
492 In this case the primitive op will not have set a temporary to the
493 tag, so we shouldn't generate a switch statment. Instead we just
497 cgInlineAlts gc_flag uniq (StgAlgAlts ty [alt@(con,args,use_mask,rhs)] StgNoDefault)
498 = cgAlgAltRhs gc_flag con args use_mask rhs
501 Second case: algebraic case, several alternatives.
502 Tag is held in a temporary.
505 cgInlineAlts gc_flag uniq (StgAlgAlts ty alts deflt)
506 = cgAlgAlts gc_flag uniq AbsCNop{-restore_cc-} False{-no semi-tagging-}
507 ty alts deflt `thenFC` \ (tagged_alts, deflt_c) ->
510 absC (mkAlgAltsCSwitch tag_amode tagged_alts deflt_c)
512 -- A temporary variable to hold the tag; this is unaffected by GC because
513 -- the heap-checks in the branches occur after the switch
514 tag_amode = CTemp uniq IntKind
517 =========== OLD: we *can* now handle this case ================
519 Next, a case we can't deal with: an algebraic case with no evaluation
520 required (so it is in-line), and a default case as well. In this case
521 we require all the alternatives written out, so that we can invent
522 suitable binders to pass to the PrimOp. A default case defeats this.
523 Could be fixed, but probably isn't worth it.
527 cgInlineAlts gc_flag uniq (StgAlgAlts ty alts other_default)
528 = panic "cgInlineAlts: alg alts with default"
529 ================= END OF OLD -}
532 Third (real) case: primitive result type.
535 cgInlineAlts gc_flag uniq (StgPrimAlts ty alts deflt)
536 = cgPrimAlts gc_flag uniq ty alts deflt
540 %************************************************************************
542 \subsection[CgCase-alg-alts]{Algebraic alternatives}
544 %************************************************************************
546 In @cgAlgAlts@, none of the binders in the alternatives are
547 assumed to be yet bound.
552 -> AbstractC -- Restore-cost-centre instruction
553 -> Bool -- True <=> branches must be labelled
554 -> UniType -- From the case statement
555 -> [(Id, [Id], [Bool], PlainStgExpr)] -- The alternatives
556 -> PlainStgCaseDefault -- The default
557 -> FCode ([(ConTag, AbstractC)], -- The branches
558 AbstractC -- The default case
562 The case with a default which has a binder is different. We need to
563 pick all the constructors which aren't handled explicitly by an
564 alternative, and which return their results in registers, allocate
565 them explicitly in the heap, and jump to a join point for the default
568 OLD: All of this only works if a heap-check is required anyway, because
569 otherwise it isn't safe to allocate.
571 NEW (July 94): now false! It should work regardless of gc_flag,
572 because of the extra_branches argument now added to forkAlts.
574 We put a heap-check at the join point, for the benefit of constructors
575 which don't need to do allocation. This means that ones which do need
576 to allocate may end up doing two heap-checks; but that's just too bad.
577 (We'd need two join labels otherwise. ToDo.)
579 It's all pretty turgid anyway.
582 cgAlgAlts gc_flag uniq restore_cc semi_tagging
583 ty alts deflt@(StgBindDefault binder True{-used-} _)
584 = getIntSwitchChkrC `thenFC` \ isw_chkr ->
586 extra_branches :: [FCode (ConTag, AbstractC)]
587 extra_branches = catMaybes (map (mk_extra_branch isw_chkr) default_cons)
589 must_label_default = semi_tagging || not (null extra_branches)
591 forkAlts (map (cgAlgAlt gc_flag uniq restore_cc semi_tagging) alts)
593 (cgAlgDefault gc_flag uniq restore_cc must_label_default deflt)
596 default_join_lbl = mkDefaultLabel uniq
597 jump_instruction = CJump (CLbl default_join_lbl CodePtrKind)
599 (spec_tycon, _, spec_cons)
600 = -- trace ("cgCase:tycon:"++(ppShow 80 (ppAboves [
601 -- ppr PprDebug uniq,
603 -- ppr PprShowAll binder
605 getUniDataSpecTyCon ty
608 alt_cons = [ con | (con,_,_,_) <- alts ]
610 default_cons = [ spec_con | spec_con <- spec_cons, -- In this type
611 spec_con `not_elem` alt_cons ] -- Not handled explicitly
613 not_elem = isn'tIn "cgAlgAlts"
615 -- (mk_extra_branch con) returns the a maybe for the extra branch for con.
616 -- The "maybe" is because con may return in heap, in which case there is
617 -- nothing to do. Otherwise, we have a special case for a nullary constructor,
618 -- but in the general case we do an allocation and heap-check.
620 mk_extra_branch :: IntSwitchChecker -> DataCon -> (Maybe (FCode (ConTag, AbstractC)))
622 mk_extra_branch isw_chkr con
623 = ASSERT(isDataCon con)
624 case dataReturnConvAlg isw_chkr con of
625 ReturnInHeap -> Nothing
626 ReturnInRegs rs -> Just (getAbsC (alloc_code rs) `thenFC` \ abs_c ->
627 returnFC (tag, abs_c)
630 lf_info = mkConLFInfo con
631 tag = getDataConTag con
632 closure_lbl = mkClosureLabel con
634 -- alloc_code generates code to allocate constructor con, whose args are
635 -- in the arguments to alloc_code, assigning the result to Node.
636 alloc_code :: [MagicId] -> Code
639 = possibleHeapCheck gc_flag regs False (
640 buildDynCon binder useCurrentCostCentre con
641 (map CReg regs) (all zero_size regs)
643 idInfoToAmode PtrKind idinfo `thenFC` \ amode ->
645 absC (CAssign (CReg node) amode) `thenC`
646 absC jump_instruction
649 zero_size reg = getKindSize (kindFromMagicId reg) == 0
652 Now comes the general case
655 cgAlgAlts gc_flag uniq restore_cc must_label_branches ty alts deflt
656 {- The deflt is either StgNoDefault or a BindDefault which doesn't use the binder -}
657 = forkAlts (map (cgAlgAlt gc_flag uniq restore_cc must_label_branches) alts)
658 [{- No "extra branches" -}]
659 (cgAlgDefault gc_flag uniq restore_cc must_label_branches deflt)
663 cgAlgDefault :: GCFlag
664 -> Unique -> AbstractC -> Bool -- turgid state...
665 -> PlainStgCaseDefault -- input
666 -> FCode AbstractC -- output
668 cgAlgDefault gc_flag uniq restore_cc must_label_branch
672 cgAlgDefault gc_flag uniq restore_cc must_label_branch
673 (StgBindDefault _ False{-binder not used-} rhs)
675 = getAbsC (absC restore_cc `thenC`
676 possibleHeapCheck gc_flag [] False (cgExpr rhs)) `thenFC` \ abs_c ->
678 final_abs_c | must_label_branch = CJump (CLabelledCode lbl abs_c)
683 lbl = mkDefaultLabel uniq
686 cgAlgDefault gc_flag uniq restore_cc must_label_branch
687 (StgBindDefault binder True{-binder used-} rhs)
689 = -- We have arranged that Node points to the thing, even
690 -- even if we return in registers
691 bindNewToReg binder node mkLFArgument `thenC`
692 getAbsC (absC restore_cc `thenC`
693 possibleHeapCheck gc_flag [node] False (cgExpr rhs)
694 -- Node is live, but doesn't need to point at the thing itself;
695 -- it's ok for Node to point to an indirection or FETCH_ME
696 -- Hence no need to re-enter Node.
697 ) `thenFC` \ abs_c ->
700 final_abs_c | must_label_branch = CJump (CLabelledCode lbl abs_c)
705 lbl = mkDefaultLabel uniq
709 -> Unique -> AbstractC -> Bool -- turgid state
710 -> (Id, [Id], [Bool], PlainStgExpr)
711 -> FCode (ConTag, AbstractC)
713 cgAlgAlt gc_flag uniq restore_cc must_label_branch (con, args, use_mask, rhs)
714 = getAbsC (absC restore_cc `thenC`
715 cgAlgAltRhs gc_flag con args use_mask rhs) `thenFC` \ abs_c ->
717 final_abs_c | must_label_branch = CJump (CLabelledCode lbl abs_c)
720 returnFC (tag, final_abs_c)
722 tag = getDataConTag con
723 lbl = mkAltLabel uniq tag
725 cgAlgAltRhs :: GCFlag -> Id -> [Id] -> [Bool] -> PlainStgExpr -> Code
727 cgAlgAltRhs gc_flag con args use_mask rhs
728 = getIntSwitchChkrC `thenFC` \ isw_chkr ->
730 (live_regs, node_reqd)
731 = case (dataReturnConvAlg isw_chkr con) of
732 ReturnInHeap -> ([], True)
733 ReturnInRegs regs -> ([reg | (reg,True) <- regs `zipEqual` use_mask], False)
734 -- Pick the live registers using the use_mask
735 -- Doing so is IMPORTANT, because with semi-tagging
736 -- enabled only the live registers will have valid
739 possibleHeapCheck gc_flag live_regs node_reqd (
741 NoGC -> mapFCs bindNewToTemp args `thenFC` \ _ ->
743 GCMayHappen -> bindConArgs con args
749 %************************************************************************
751 \subsection[CgCase-semi-tagged-alts]{The code to deal with sem-tagging}
753 %************************************************************************
755 Turgid-but-non-monadic code to conjure up the required info from
756 algebraic case alternatives for semi-tagging.
759 cgSemiTaggedAlts :: IntSwitchChecker
761 -> [(Id, [Id], [Bool], PlainStgExpr)]
762 -> StgCaseDefault Id Id
765 cgSemiTaggedAlts isw_chkr uniq alts deflt
766 = Just (map (st_alt isw_chkr) alts, st_deflt deflt)
768 st_deflt StgNoDefault = Nothing
770 st_deflt (StgBindDefault binder binder_used _)
771 = Just (if binder_used then Just binder else Nothing,
772 (CCallProfCtrMacro SLIT("RET_SEMI_BY_DEFAULT") [], -- ToDo: monadise?
776 st_alt isw_chkr (con, args, use_mask, _)
777 = case (dataReturnConvAlg isw_chkr con) of
780 -- Ha! Nothing to do; Node already points to the thing
782 (CCallProfCtrMacro SLIT("RET_SEMI_IN_HEAP") -- ToDo: monadise?
783 [mkIntCLit (length args)], -- how big the thing in the heap is
788 -- We have to load the live registers from the constructor
789 -- pointed to by Node.
791 (_, regs_w_offsets) = layOutDynCon con kindFromMagicId regs
793 used_regs = selectByMask use_mask regs
795 used_regs_w_offsets = [ ro | ro@(reg,offset) <- regs_w_offsets,
796 reg `is_elem` used_regs]
798 is_elem = isIn "cgSemiTaggedAlts"
802 CCallProfCtrMacro SLIT("RET_SEMI_IN_REGS") -- ToDo: macroise?
803 [mkIntCLit (length regs_w_offsets),
804 mkIntCLit (length used_regs_w_offsets)],
805 CSimultaneous (mkAbstractCs (map move_to_reg used_regs_w_offsets))],
808 con_tag = getDataConTag con
809 join_label = mkAltLabel uniq con_tag
811 move_to_reg :: (MagicId, VirtualHeapOffset {-from Node-}) -> AbstractC
812 move_to_reg (reg, offset)
813 = CAssign (CReg reg) (CVal (NodeRel offset) (kindFromMagicId reg))
816 %************************************************************************
818 \subsection[CgCase-prim-alts]{Primitive alternatives}
820 %************************************************************************
822 @cgPrimAlts@ generates a suitable @CSwitch@ for dealing with the
823 alternatives of a primitive @case@, given an addressing mode for the
824 thing to scrutinise. It also keeps track of the maximum stack depth
825 encountered down any branch.
827 As usual, no binders in the alternatives are yet bound.
833 -> [(BasicLit, PlainStgExpr)] -- Alternatives
834 -> PlainStgCaseDefault -- Default
837 cgPrimAlts gc_flag uniq ty alts deflt
838 = cgPrimAltsGivenScrutinee gc_flag scrutinee alts deflt
840 -- A temporary variable, or standard register, to hold the result
841 scrutinee = case gc_flag of
842 NoGC -> CTemp uniq kind
843 GCMayHappen -> CReg (dataReturnConvPrim kind)
845 kind = kindFromType ty
848 cgPrimAltsGivenScrutinee gc_flag scrutinee alts deflt
849 = forkAlts (map (cgPrimAlt gc_flag) alts)
850 [{- No "extra branches" -}]
851 (cgPrimDefault gc_flag scrutinee deflt) `thenFC` \ (alt_absCs, deflt_absC) ->
852 absC (CSwitch scrutinee alt_absCs deflt_absC)
853 -- CSwitch does sensible things with one or zero alternatives
857 -> (BasicLit, PlainStgExpr) -- The alternative
858 -> FCode (BasicLit, AbstractC) -- Its compiled form
860 cgPrimAlt gc_flag (lit, rhs)
861 = getAbsC rhs_code `thenFC` \ absC ->
864 rhs_code = possibleHeapCheck gc_flag [] False (cgExpr rhs )
866 cgPrimDefault :: GCFlag
867 -> CAddrMode -- Scrutinee
868 -> PlainStgCaseDefault
871 cgPrimDefault gc_flag scrutinee StgNoDefault
872 = panic "cgPrimDefault: No default in prim case"
874 cgPrimDefault gc_flag scrutinee (StgBindDefault _ False{-binder not used-} rhs)
875 = getAbsC (possibleHeapCheck gc_flag [] False (cgExpr rhs ))
877 cgPrimDefault gc_flag scrutinee (StgBindDefault binder True{-used-} rhs)
878 = getAbsC (possibleHeapCheck gc_flag regs False rhs_code)
880 regs = if isFollowableKind (getAmodeKind scrutinee) then
883 rhs_code = bindNewPrimToAmode binder scrutinee `thenC`
888 %************************************************************************
890 \subsection[CgCase-tidy]{Code for tidying up prior to an eval}
892 %************************************************************************
895 saveVolatileVarsAndRegs
896 :: PlainStgLiveVars -- Vars which should be made safe
897 -> FCode (AbstractC, -- Assignments to do the saves
898 EndOfBlockInfo, -- New sequel, recording where the return
900 Maybe VirtualSpBOffset) -- Slot for current cost centre
903 saveVolatileVarsAndRegs vars
904 = saveVolatileVars vars `thenFC` \ var_saves ->
905 saveCurrentCostCentre `thenFC` \ (maybe_cc_slot, cc_save) ->
906 saveReturnAddress `thenFC` \ (new_eob_info, ret_save) ->
907 returnFC (mkAbstractCs [var_saves, cc_save, ret_save],
912 saveVolatileVars :: PlainStgLiveVars -- Vars which should be made safe
913 -> FCode AbstractC -- Assignments to to the saves
915 saveVolatileVars vars
916 = save_em (uniqSetToList vars)
918 save_em [] = returnFC AbsCNop
921 = getCAddrModeIfVolatile var `thenFC` \ v ->
923 Nothing -> save_em vars -- Non-volatile, so carry on
926 Just vol_amode -> -- Aha! It's volatile
927 save_var var vol_amode `thenFC` \ abs_c ->
928 save_em vars `thenFC` \ abs_cs ->
929 returnFC (abs_c `mkAbsCStmts` abs_cs)
931 save_var var vol_amode
932 | isFollowableKind kind
933 = allocAStack `thenFC` \ a_slot ->
934 rebindToAStack var a_slot `thenC`
935 getSpARelOffset a_slot `thenFC` \ spa_rel ->
936 returnFC (CAssign (CVal spa_rel kind) vol_amode)
938 = allocBStack (getKindSize kind) `thenFC` \ b_slot ->
939 rebindToBStack var b_slot `thenC`
940 getSpBRelOffset b_slot `thenFC` \ spb_rel ->
941 returnFC (CAssign (CVal spb_rel kind) vol_amode)
943 kind = getAmodeKind vol_amode
945 saveReturnAddress :: FCode (EndOfBlockInfo, AbstractC)
947 = getEndOfBlockInfo `thenFC` \ eob_info@(EndOfBlockInfo vA vB sequel) ->
949 -- See if it is volatile
951 InRetReg -> -- Yes, it's volatile
952 allocBStack retKindSize `thenFC` \ b_slot ->
953 getSpBRelOffset b_slot `thenFC` \ spb_rel ->
955 returnFC (EndOfBlockInfo vA vB (OnStack b_slot),
956 CAssign (CVal spb_rel RetKind) (CReg RetReg))
958 UpdateCode _ -> -- It's non-volatile all right, but we still need
959 -- to allocate a B-stack slot for it, *solely* to make
960 -- sure that update frames for different values do not
961 -- appear adjacent on the B stack. This makes sure
962 -- that B-stack squeezing works ok.
964 allocBStack retKindSize `thenFC` \ b_slot ->
965 returnFC (eob_info, AbsCNop)
967 other -> -- No, it's non-volatile, so do nothing
968 returnFC (eob_info, AbsCNop)
971 Note about B-stack squeezing. Consider the following:`
973 y = [...] \u [] -> ...
974 x = [y] \u [] -> case y of (a,b) -> a
976 The code for x will push an update frame, and then enter y. The code
977 for y will push another update frame. If the B-stack-squeezer then
978 wakes up, it will see two update frames right on top of each other,
979 and will combine them. This is WRONG, of course, because x's value is
982 The fix implemented above makes sure that we allocate an (unused)
983 B-stack slot before entering y. You can think of this as holding the
984 saved value of RetAddr, which (after pushing x's update frame will be
985 some update code ptr). The compiler is clever enough to load the
986 static update code ptr into RetAddr before entering ~a~, but the slot
987 is still there to separate the update frames.
989 When we save the current cost centre (which is done for lexical
990 scoping), we allocate a free B-stack location, and return (a)~the
991 virtual offset of the location, to pass on to the alternatives, and
992 (b)~the assignment to do the save (just as for @saveVolatileVars@).
995 saveCurrentCostCentre ::
996 FCode (Maybe VirtualSpBOffset, -- Where we decide to store it
997 -- Nothing if not lexical CCs
998 AbstractC) -- Assignment to save it
999 -- AbsCNop if not lexical CCs
1001 saveCurrentCostCentre
1002 = isSwitchSetC SccProfilingOn `thenFC` \ doing_profiling ->
1003 if not doing_profiling then
1004 returnFC (Nothing, AbsCNop)
1006 allocBStack (getKindSize CostCentreKind) `thenFC` \ b_slot ->
1007 getSpBRelOffset b_slot `thenFC` \ spb_rel ->
1008 returnFC (Just b_slot,
1009 CAssign (CVal spb_rel CostCentreKind) (CReg CurCostCentre))
1011 restoreCurrentCostCentre :: Maybe VirtualSpBOffset -> FCode AbstractC
1013 restoreCurrentCostCentre Nothing
1015 restoreCurrentCostCentre (Just b_slot)
1016 = getSpBRelOffset b_slot `thenFC` \ spb_rel ->
1017 freeBStkSlot b_slot `thenC`
1018 returnFC (CCallProfCCMacro SLIT("RESTORE_CCC") [CVal spb_rel CostCentreKind])
1019 -- we use the RESTORE_CCC macro, rather than just
1020 -- assigning into CurCostCentre, in case RESTORE_CCC
1021 -- has some sanity-checking in it.
1025 %************************************************************************
1027 \subsection[CgCase-return-vec]{Building a return vector}
1029 %************************************************************************
1031 Build a return vector, and return a suitable label addressing
1035 mkReturnVector :: Unique
1037 -> [(ConTag, AbstractC)] -- Branch codes
1038 -> AbstractC -- Default case
1041 mkReturnVector uniq ty tagged_alt_absCs deflt_absC
1043 (return_vec_amode, vtbl_body) = case (ctrlReturnConvAlg spec_tycon) of {
1045 UnvectoredReturn _ ->
1046 (CUnVecLbl ret_label vtbl_label,
1047 absC (CRetUnVector vtbl_label
1048 (CLabelledCode ret_label
1049 (mkAlgAltsCSwitch (CReg TagReg)
1052 VectoredReturn table_size ->
1053 (CLbl vtbl_label DataPtrKind,
1054 absC (CRetVector vtbl_label
1055 -- must restore cc before each alt, if required
1056 (map mk_vector_entry [fIRST_TAG .. (table_size+fIRST_TAG-1)])
1059 -- Leave nops and comments in for now; they are eliminated
1060 -- lazily as it's printed.
1061 -- (case (nonemptyAbsC deflt_absC) of
1062 -- Nothing -> AbsCNop
1067 returnFC return_vec_amode
1071 (spec_tycon,_,_) = case (getUniDataSpecTyCon_maybe ty) of -- *must* be a real "data" type constructor
1073 Nothing -> error ("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: "++(ppShow 80 (ppr PprDebug ty)))
1075 vtbl_label = mkVecTblLabel uniq
1076 ret_label = mkReturnPtLabel uniq
1078 mk_vector_entry :: ConTag -> Maybe CAddrMode
1080 = case [ absC | (t, absC) <- tagged_alt_absCs, t == tag ] of
1082 [absC] -> Just (CCode absC)
1083 _ -> panic "mkReturnVector: too many"
1086 %************************************************************************
1088 \subsection[CgCase-utils]{Utilities for handling case expressions}
1090 %************************************************************************
1092 @possibleHeapCheck@ tests a flag passed in to decide whether to
1093 do a heap check or not.
1096 possibleHeapCheck :: GCFlag -> [MagicId] -> Bool -> Code -> Code
1098 possibleHeapCheck GCMayHappen regs node_reqd code = heapCheck regs node_reqd code
1099 possibleHeapCheck NoGC _ _ code = code
1102 Select a restricted set of registers based on a usage mask.
1105 selectByMask [] [] = []
1106 selectByMask (True:ms) (x:xs) = x : selectByMask ms xs
1107 selectByMask (False:ms) (x:xs) = selectByMask ms xs