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...
24 import PrelInfo ( PrimOp(..), primOpCanTriggerGC
25 IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp)
26 IF_ATTACK_PRAGMAS(COMMA pprPrimOp)
28 import Type ( primRepFromType, getTyConDataCons,
29 getUniDataSpecTyCon, getUniDataSpecTyCon_maybe,
33 import CgBindery -- all of it
34 import CgCon ( buildDynCon, bindConArgs )
35 import CgExpr ( cgExpr, getPrimOpArgAmodes )
36 import CgHeapery ( heapCheck )
37 import CgRetConv -- lots of stuff
38 import CgStackery -- plenty
39 import CgTailCall ( tailCallBusiness, performReturn )
40 import CgUsages -- and even more
41 import CLabel -- bunches of things...
42 import ClosureInfo {-( blackHoleClosureInfo, mkConLFInfo, mkLFArgument,
45 import CostCentre ( useCurrentCostCentre, CostCentre )
46 import Literal ( literalPrimRep )
47 import Id ( getDataConTag, getIdPrimRep, fIRST_TAG, isDataCon,
48 toplevelishId, getInstantiatedDataConSig,
49 ConTag(..), DataCon(..)
51 import Maybes ( catMaybes, Maybe(..) )
52 import PrimRep ( getPrimRepSize, isFollowableRep, retPrimRepSize, PrimRep(..) )
53 import UniqSet -- ( uniqSetToList, UniqSet(..) )
59 = GCMayHappen -- The scrutinee may involve GC, so everything must be
60 -- tidy before the code for the scrutinee.
62 | NoGC -- The scrutinee is a primitive value, or a call to a
63 -- primitive op which does no GC. Hence the case can
64 -- be done inline, without tidying up first.
67 It is quite interesting to decide whether to put a heap-check
68 at the start of each alternative. Of course we certainly have
69 to do so if the case forces an evaluation, or if there is a primitive
70 op which can trigger GC.
72 A more interesting situation is this:
79 default -> !C!; ...C...
82 where \tr{!x!} indicates a possible heap-check point. The heap checks
83 in the alternatives {\em can} be omitted, in which case the topmost
84 heapcheck will take their worst case into account.
86 In favour of omitting \tr{!B!}, \tr{!C!}:
90 {\em May} save a heap overflow test,
91 if ...A... allocates anything. The other advantage
92 of this is that we can use relative addressing
93 from a single Hp to get at all the closures so allocated.
95 No need to save volatile vars etc across the case
102 May do more allocation than reqd. This sometimes bites us
103 badly. For example, nfib (ha!) allocates about 30\% more space if the
104 worst-casing is done, because many many calls to nfib are leaf calls
105 which don't need to allocate anything.
107 This never hurts us if there is only one alternative.
111 *** NOT YET DONE *** The difficulty is that \tr{!B!}, \tr{!C!} need
112 to take account of what is live, and that includes all live volatile
113 variables, even if they also have stable analogues. Furthermore, the
114 stack pointers must be lined up properly so that GC sees tidy stacks.
115 If these things are done, then the heap checks can be done at \tr{!B!} and
116 \tr{!C!} without a full save-volatile-vars sequence.
127 Several special cases for primitive operations.
129 ******* TO DO TO DO: fix what follows
133 case (op x1 ... xn) of
136 where the type of the case scrutinee is a multi-constuctor algebraic type.
137 Then we simply compile code for
145 case (op x1 ... xn) of
149 where the type of the case scrutinee is a multi-constuctor algebraic type.
150 we just bomb out at the moment. It never happens in practice.
152 **** END OF TO DO TO DO
155 cgCase scrut@(StgPrim op args _) live_in_whole_case live_in_alts uniq
156 (StgAlgAlts _ alts (StgBindDefault id _ deflt_rhs))
157 = if not (null alts) then
158 panic "cgCase: case on PrimOp with default *and* alts\n"
159 -- For now, die if alts are non-empty
162 pprTrace "cgCase:prim app returning alg data type: bad code!" (ppr PprDebug scrut) $
163 -- See above TO DO TO DO
165 cgExpr (StgLet (StgNonRec id scrut_rhs) deflt_rhs)
167 scrut_rhs = StgRhsClosure useCurrentCostCentre stgArgOcc{-safe-} scrut_free_vars
169 scrut_free_vars = [ fv | StgVarArg fv <- args, not (toplevelishId fv) ]
175 cgCase (StgPrim op args _) live_in_whole_case live_in_alts uniq alts
176 | not (primOpCanTriggerGC op)
178 -- Get amodes for the arguments and results
179 getPrimOpArgAmodes op args `thenFC` \ arg_amodes ->
181 result_amodes = getPrimAppResultAmodes uniq alts
182 liveness_mask = panic "cgCase: liveness of non-GC-ing primop touched\n"
184 -- Perform the operation
185 getVolatileRegs live_in_alts `thenFC` \ vol_regs ->
187 absC (COpStmt result_amodes op
188 arg_amodes -- note: no liveness arg
189 liveness_mask vol_regs) `thenC`
191 -- Scrutinise the result
192 cgInlineAlts NoGC uniq alts
194 | otherwise -- *Can* trigger GC
195 = getPrimOpArgAmodes op args `thenFC` \ arg_amodes ->
196 --NO: getIntSwitchChkrC `thenFC` \ isw_chkr ->
198 -- Get amodes for the arguments and results, and assign to regs
199 -- (Can-trigger-gc primops guarantee to have their (nonRobust)
202 op_result_regs = assignPrimOpResultRegs {-NO:isw_chkr-} op
204 op_result_amodes = map CReg op_result_regs
206 (op_arg_amodes, liveness_mask, arg_assts)
207 = makePrimOpArgsRobust {-NO:isw_chkr-} op arg_amodes
209 liveness_arg = mkIntCLit liveness_mask
211 -- Tidy up in case GC happens...
213 -- Nota Bene the use of live_in_whole_case in nukeDeadBindings.
214 -- Reason: the arg_assts computed above may refer to some stack slots
215 -- which are not live in the alts. So we mustn't use those slots
216 -- to save volatile vars in!
217 nukeDeadBindings live_in_whole_case `thenC`
218 saveVolatileVars live_in_alts `thenFC` \ volatile_var_save_assts ->
220 getEndOfBlockInfo `thenFC` \ eob_info ->
221 forkEval eob_info nopC
222 (getAbsC (cgInlineAlts GCMayHappen uniq alts) `thenFC` \ abs_c ->
223 absC (CRetUnVector vtbl_label (CLabelledCode return_label abs_c))
225 returnFC (CaseAlts (CUnVecLbl return_label vtbl_label)
226 Nothing{-no semi-tagging-}))
227 `thenFC` \ new_eob_info ->
229 -- Record the continuation info
230 setEndOfBlockInfo new_eob_info (
232 -- Now "return" to the inline alternatives; this will get
233 -- compiled to a fall-through.
235 simultaneous_assts = arg_assts `mkAbsCStmts` volatile_var_save_assts
237 -- do_op_and_continue will be passed an amode for the continuation
238 do_op_and_continue sequel
239 = absC (COpStmt op_result_amodes
241 (pin_liveness op liveness_arg op_arg_amodes)
246 sequelToAmode sequel `thenFC` \ dest_amode ->
247 absC (CReturn dest_amode DirectReturn)
249 -- Note: we CJump even for algebraic data types,
250 -- because cgInlineAlts always generates code, never a
253 performReturn simultaneous_assts do_op_and_continue live_in_alts
256 -- for all PrimOps except ccalls, we pin the liveness info
257 -- on as the first "argument"
258 -- ToDo: un-duplicate?
260 pin_liveness (CCallOp _ _ _ _ _) _ args = args
261 pin_liveness other_op liveness_arg args
264 vtbl_label = mkVecTblLabel uniq
265 return_label = mkReturnPtLabel uniq
269 Another special case: scrutinising a primitive-typed variable. No
270 evaluation required. We don't save volatile variables, nor do we do a
271 heap-check in the alternatives. Instead, the heap usage of the
272 alternatives is worst-cased and passed upstream. This can result in
273 allocating more heap than strictly necessary, but it will sometimes
274 eliminate a heap check altogether.
277 cgCase (StgApp v [] _) live_in_whole_case live_in_alts uniq (StgPrimAlts ty alts deflt)
278 = getAtomAmode v `thenFC` \ amode ->
279 cgPrimAltsGivenScrutinee NoGC amode alts deflt
282 Special case: scrutinising a non-primitive variable.
283 This can be done a little better than the general case, because
284 we can reuse/trim the stack slot holding the variable (if it is in one).
287 cgCase (StgApp (StgVarArg fun) args _ {-lvs must be same as live_in_alts-})
288 live_in_whole_case live_in_alts uniq alts@(StgAlgAlts _ _ _)
290 getCAddrModeAndInfo fun `thenFC` \ (fun_amode, lf_info) ->
291 getAtomAmodes args `thenFC` \ arg_amodes ->
293 -- Squish the environment
294 nukeDeadBindings live_in_alts `thenC`
295 saveVolatileVarsAndRegs live_in_alts
296 `thenFC` \ (save_assts, alts_eob_info, maybe_cc_slot) ->
298 forkEval alts_eob_info
299 nopC (cgEvalAlts maybe_cc_slot uniq alts) `thenFC` \ scrut_eob_info ->
300 setEndOfBlockInfo scrut_eob_info (
301 tailCallBusiness fun fun_amode lf_info arg_amodes live_in_alts save_assts
306 Finally, here is the general case.
309 cgCase expr live_in_whole_case live_in_alts uniq alts
310 = -- Figure out what volatile variables to save
311 nukeDeadBindings live_in_whole_case `thenC`
312 saveVolatileVarsAndRegs live_in_alts
313 `thenFC` \ (save_assts, alts_eob_info, maybe_cc_slot) ->
315 -- Save those variables right now!
316 absC save_assts `thenC`
318 forkEval alts_eob_info
319 (nukeDeadBindings live_in_alts)
320 (cgEvalAlts maybe_cc_slot uniq alts) `thenFC` \ scrut_eob_info ->
322 setEndOfBlockInfo scrut_eob_info (cgExpr expr)
325 %************************************************************************
327 \subsection[CgCase-primops]{Primitive applications}
329 %************************************************************************
331 Get result amodes for a primitive operation, in the case wher GC can't happen.
332 The amodes are returned in canonical order, ready for the prim-op!
334 Alg case: temporaries named as in the alternatives,
335 plus (CTemp u) for the tag (if needed)
338 This is all disgusting, because these amodes must be consistent with those
339 invented by CgAlgAlts.
342 getPrimAppResultAmodes
349 -- If there's an StgBindDefault which does use the bound
350 -- variable, then we can only handle it if the type involved is
351 -- an enumeration type. That's important in the case
357 -- The only reason for the restriction to *enumeration* types is our
358 -- inability to invent suitable temporaries to hold the results;
359 -- Elaborating the CTemp addr mode to have a second uniq field
360 -- (which would simply count from 1) would solve the problem.
361 -- Anyway, cgInlineAlts is now capable of handling all cases;
362 -- it's only this function which is being wimpish.
364 getPrimAppResultAmodes uniq (StgAlgAlts ty alts (StgBindDefault _ True {- used -} _))
365 | isEnumerationTyCon spec_tycon = [tag_amode]
366 | otherwise = panic "getPrimAppResultAmodes: non-enumeration algebraic alternatives with default"
368 -- A temporary variable to hold the tag; this is unaffected by GC because
369 -- the heap-checks in the branches occur after the switch
370 tag_amode = CTemp uniq IntRep
371 (spec_tycon, _, _) = getUniDataSpecTyCon ty
373 getPrimAppResultAmodes uniq (StgAlgAlts ty alts other_default)
374 -- Default is either StgNoDefault or StgBindDefault with unused binder
376 [_] -> arg_amodes -- No need for a tag
377 other -> tag_amode : arg_amodes
379 -- A temporary variable to hold the tag; this is unaffected by GC because
380 -- the heap-checks in the branches occur after the switch
381 tag_amode = CTemp uniq IntRep
383 -- Sort alternatives into canonical order; there must be a complete
384 -- set because there's no default case.
385 sorted_alts = sortLt lt alts
386 (con1,_,_,_) `lt` (con2,_,_,_) = getDataConTag con1 < getDataConTag con2
388 arg_amodes :: [CAddrMode]
390 -- Turn them into amodes
391 arg_amodes = concat (map mk_amodes sorted_alts)
392 mk_amodes (con, args, use_mask, rhs)
393 = [ CTemp (getItsUnique arg) (getIdPrimRep arg) | arg <- args ]
396 The situation is simpler for primitive
397 results, because there is only one!
400 getPrimAppResultAmodes uniq (StgPrimAlts ty _ _)
403 kind = primRepFromType ty
407 %************************************************************************
409 \subsection[CgCase-alts]{Alternatives}
411 %************************************************************************
413 @cgEvalAlts@ returns an addressing mode for a continuation for the
414 alternatives of a @case@, used in a context when there
415 is some evaluation to be done.
418 cgEvalAlts :: Maybe VirtualSpBOffset -- Offset of cost-centre to be restored, if any
421 -> FCode Sequel -- Any addr modes inside are guaranteed to be a label
422 -- so that we can duplicate it without risk of
425 cgEvalAlts cc_slot uniq (StgAlgAlts ty alts deflt)
426 = -- Generate the instruction to restore cost centre, if any
427 restoreCurrentCostCentre cc_slot `thenFC` \ cc_restore ->
428 getIntSwitchChkrC `thenFC` \ isw_chkr ->
430 -- Generate sequel info for use downstream
431 -- At the moment, we only do it if the type is vector-returnable.
432 -- Reason: if not, then it costs extra to label the
433 -- alternatives, because we'd get return code like:
435 -- switch TagReg { 0 : JMP(alt_1); 1 : JMP(alt_2) ..etc }
437 -- which is worse than having the alt code in the switch statement
440 (spec_tycon, _, _) = getUniDataSpecTyCon ty
443 = case ctrlReturnConvAlg spec_tycon of
444 VectoredReturn _ -> True
448 = if not use_labelled_alts then
449 Nothing -- no semi-tagging info
451 cgSemiTaggedAlts isw_chkr uniq alts deflt -- Just <something>
453 cgAlgAlts GCMayHappen uniq cc_restore use_labelled_alts ty alts deflt
454 `thenFC` \ (tagged_alt_absCs, deflt_absC) ->
456 mkReturnVector uniq ty tagged_alt_absCs deflt_absC `thenFC` \ return_vec ->
458 returnFC (CaseAlts return_vec semi_tagged_stuff)
460 cgEvalAlts cc_slot uniq (StgPrimAlts ty alts deflt)
461 = -- Generate the instruction to restore cost centre, if any
462 restoreCurrentCostCentre cc_slot `thenFC` \ cc_restore ->
464 -- Generate the switch
465 getAbsC (cgPrimAlts GCMayHappen uniq ty alts deflt) `thenFC` \ abs_c ->
467 -- Generate the labelled block, starting with restore-cost-centre
468 absC (CRetUnVector vtbl_label
469 (CLabelledCode return_label (cc_restore `mkAbsCStmts` abs_c)))
471 -- Return an amode for the block
472 returnFC (CaseAlts (CUnVecLbl return_label vtbl_label) Nothing{-no semi-tagging-})
474 vtbl_label = mkVecTblLabel uniq
475 return_label = mkReturnPtLabel uniq
480 cgInlineAlts :: GCFlag -> Unique
485 First case: algebraic case, exactly one alternative, no default.
486 In this case the primitive op will not have set a temporary to the
487 tag, so we shouldn't generate a switch statment. Instead we just
491 cgInlineAlts gc_flag uniq (StgAlgAlts ty [alt@(con,args,use_mask,rhs)] StgNoDefault)
492 = cgAlgAltRhs gc_flag con args use_mask rhs
495 Second case: algebraic case, several alternatives.
496 Tag is held in a temporary.
499 cgInlineAlts gc_flag uniq (StgAlgAlts ty alts deflt)
500 = cgAlgAlts gc_flag uniq AbsCNop{-restore_cc-} False{-no semi-tagging-}
501 ty alts deflt `thenFC` \ (tagged_alts, deflt_c) ->
504 absC (mkAlgAltsCSwitch tag_amode tagged_alts deflt_c)
506 -- A temporary variable to hold the tag; this is unaffected by GC because
507 -- the heap-checks in the branches occur after the switch
508 tag_amode = CTemp uniq IntRep
511 Third (real) case: primitive result type.
514 cgInlineAlts gc_flag uniq (StgPrimAlts ty alts deflt)
515 = cgPrimAlts gc_flag uniq ty alts deflt
519 %************************************************************************
521 \subsection[CgCase-alg-alts]{Algebraic alternatives}
523 %************************************************************************
525 In @cgAlgAlts@, none of the binders in the alternatives are
526 assumed to be yet bound.
531 -> AbstractC -- Restore-cost-centre instruction
532 -> Bool -- True <=> branches must be labelled
533 -> Type -- From the case statement
534 -> [(Id, [Id], [Bool], StgExpr)] -- The alternatives
535 -> StgCaseDefault -- The default
536 -> FCode ([(ConTag, AbstractC)], -- The branches
537 AbstractC -- The default case
541 The case with a default which has a binder is different. We need to
542 pick all the constructors which aren't handled explicitly by an
543 alternative, and which return their results in registers, allocate
544 them explicitly in the heap, and jump to a join point for the default
547 OLD: All of this only works if a heap-check is required anyway, because
548 otherwise it isn't safe to allocate.
550 NEW (July 94): now false! It should work regardless of gc_flag,
551 because of the extra_branches argument now added to forkAlts.
553 We put a heap-check at the join point, for the benefit of constructors
554 which don't need to do allocation. This means that ones which do need
555 to allocate may end up doing two heap-checks; but that's just too bad.
556 (We'd need two join labels otherwise. ToDo.)
558 It's all pretty turgid anyway.
561 cgAlgAlts gc_flag uniq restore_cc semi_tagging
562 ty alts deflt@(StgBindDefault binder True{-used-} _)
563 = getIntSwitchChkrC `thenFC` \ isw_chkr ->
565 extra_branches :: [FCode (ConTag, AbstractC)]
566 extra_branches = catMaybes (map (mk_extra_branch isw_chkr) default_cons)
568 must_label_default = semi_tagging || not (null extra_branches)
570 forkAlts (map (cgAlgAlt gc_flag uniq restore_cc semi_tagging) alts)
572 (cgAlgDefault gc_flag uniq restore_cc must_label_default deflt)
575 default_join_lbl = mkDefaultLabel uniq
576 jump_instruction = CJump (CLbl default_join_lbl CodePtrRep)
578 (spec_tycon, _, spec_cons)
579 = -- trace ("cgCase:tycon:"++(ppShow 80 (ppAboves [
580 -- ppr PprDebug uniq,
582 -- ppr PprShowAll binder
584 getUniDataSpecTyCon ty
587 alt_cons = [ con | (con,_,_,_) <- alts ]
589 default_cons = [ spec_con | spec_con <- spec_cons, -- In this type
590 spec_con `not_elem` alt_cons ] -- Not handled explicitly
592 not_elem = isn'tIn "cgAlgAlts"
594 -- (mk_extra_branch con) returns the a maybe for the extra branch for con.
595 -- The "maybe" is because con may return in heap, in which case there is
596 -- nothing to do. Otherwise, we have a special case for a nullary constructor,
597 -- but in the general case we do an allocation and heap-check.
599 mk_extra_branch :: IntSwitchChecker -> DataCon -> (Maybe (FCode (ConTag, AbstractC)))
601 mk_extra_branch isw_chkr con
602 = ASSERT(isDataCon con)
603 case dataReturnConvAlg isw_chkr con of
604 ReturnInHeap -> Nothing
605 ReturnInRegs rs -> Just (getAbsC (alloc_code rs) `thenFC` \ abs_c ->
606 returnFC (tag, abs_c)
609 lf_info = mkConLFInfo con
610 tag = getDataConTag con
611 closure_lbl = mkClosureLabel con
613 -- alloc_code generates code to allocate constructor con, whose args are
614 -- in the arguments to alloc_code, assigning the result to Node.
615 alloc_code :: [MagicId] -> Code
618 = possibleHeapCheck gc_flag regs False (
619 buildDynCon binder useCurrentCostCentre con
620 (map CReg regs) (all zero_size regs)
622 idInfoToAmode PtrRep idinfo `thenFC` \ amode ->
624 absC (CAssign (CReg node) amode) `thenC`
625 absC jump_instruction
628 zero_size reg = getPrimRepSize (kindFromMagicId reg) == 0
631 Now comes the general case
634 cgAlgAlts gc_flag uniq restore_cc must_label_branches ty alts deflt
635 {- The deflt is either StgNoDefault or a BindDefault which doesn't use the binder -}
636 = forkAlts (map (cgAlgAlt gc_flag uniq restore_cc must_label_branches) alts)
637 [{- No "extra branches" -}]
638 (cgAlgDefault gc_flag uniq restore_cc must_label_branches deflt)
642 cgAlgDefault :: GCFlag
643 -> Unique -> AbstractC -> Bool -- turgid state...
644 -> StgCaseDefault -- input
645 -> FCode AbstractC -- output
647 cgAlgDefault gc_flag uniq restore_cc must_label_branch
651 cgAlgDefault gc_flag uniq restore_cc must_label_branch
652 (StgBindDefault _ False{-binder not used-} rhs)
654 = getAbsC (absC restore_cc `thenC`
655 possibleHeapCheck gc_flag [] False (cgExpr rhs)) `thenFC` \ abs_c ->
657 final_abs_c | must_label_branch = CJump (CLabelledCode lbl abs_c)
662 lbl = mkDefaultLabel uniq
665 cgAlgDefault gc_flag uniq restore_cc must_label_branch
666 (StgBindDefault binder True{-binder used-} rhs)
668 = -- We have arranged that Node points to the thing, even
669 -- even if we return in registers
670 bindNewToReg binder node mkLFArgument `thenC`
671 getAbsC (absC restore_cc `thenC`
672 possibleHeapCheck gc_flag [node] False (cgExpr rhs)
673 -- Node is live, but doesn't need to point at the thing itself;
674 -- it's ok for Node to point to an indirection or FETCH_ME
675 -- Hence no need to re-enter Node.
676 ) `thenFC` \ abs_c ->
679 final_abs_c | must_label_branch = CJump (CLabelledCode lbl abs_c)
684 lbl = mkDefaultLabel uniq
688 -> Unique -> AbstractC -> Bool -- turgid state
689 -> (Id, [Id], [Bool], StgExpr)
690 -> FCode (ConTag, AbstractC)
692 cgAlgAlt gc_flag uniq restore_cc must_label_branch (con, args, use_mask, rhs)
693 = getAbsC (absC restore_cc `thenC`
694 cgAlgAltRhs gc_flag con args use_mask rhs) `thenFC` \ abs_c ->
696 final_abs_c | must_label_branch = CJump (CLabelledCode lbl abs_c)
699 returnFC (tag, final_abs_c)
701 tag = getDataConTag con
702 lbl = mkAltLabel uniq tag
704 cgAlgAltRhs :: GCFlag -> Id -> [Id] -> [Bool] -> StgExpr -> Code
706 cgAlgAltRhs gc_flag con args use_mask rhs
707 = getIntSwitchChkrC `thenFC` \ isw_chkr ->
709 (live_regs, node_reqd)
710 = case (dataReturnConvAlg isw_chkr con) of
711 ReturnInHeap -> ([], True)
712 ReturnInRegs regs -> ([reg | (reg,True) <- regs `zipEqual` use_mask], False)
713 -- Pick the live registers using the use_mask
714 -- Doing so is IMPORTANT, because with semi-tagging
715 -- enabled only the live registers will have valid
718 possibleHeapCheck gc_flag live_regs node_reqd (
720 NoGC -> mapFCs bindNewToTemp args `thenFC` \ _ ->
722 GCMayHappen -> bindConArgs con args
728 %************************************************************************
730 \subsection[CgCase-semi-tagged-alts]{The code to deal with sem-tagging}
732 %************************************************************************
734 Turgid-but-non-monadic code to conjure up the required info from
735 algebraic case alternatives for semi-tagging.
738 cgSemiTaggedAlts :: IntSwitchChecker
740 -> [(Id, [Id], [Bool], StgExpr)]
741 -> GenStgCaseDefault Id Id
744 cgSemiTaggedAlts isw_chkr uniq alts deflt
745 = Just (map (st_alt isw_chkr) alts, st_deflt deflt)
747 st_deflt StgNoDefault = Nothing
749 st_deflt (StgBindDefault binder binder_used _)
750 = Just (if binder_used then Just binder else Nothing,
751 (CCallProfCtrMacro SLIT("RET_SEMI_BY_DEFAULT") [], -- ToDo: monadise?
755 st_alt isw_chkr (con, args, use_mask, _)
756 = case (dataReturnConvAlg isw_chkr con) of
759 -- Ha! Nothing to do; Node already points to the thing
761 (CCallProfCtrMacro SLIT("RET_SEMI_IN_HEAP") -- ToDo: monadise?
762 [mkIntCLit (length args)], -- how big the thing in the heap is
767 -- We have to load the live registers from the constructor
768 -- pointed to by Node.
770 (_, regs_w_offsets) = layOutDynCon con kindFromMagicId regs
772 used_regs = selectByMask use_mask regs
774 used_regs_w_offsets = [ ro | ro@(reg,offset) <- regs_w_offsets,
775 reg `is_elem` used_regs]
777 is_elem = isIn "cgSemiTaggedAlts"
781 CCallProfCtrMacro SLIT("RET_SEMI_IN_REGS") -- ToDo: macroise?
782 [mkIntCLit (length regs_w_offsets),
783 mkIntCLit (length used_regs_w_offsets)],
784 CSimultaneous (mkAbstractCs (map move_to_reg used_regs_w_offsets))],
787 con_tag = getDataConTag con
788 join_label = mkAltLabel uniq con_tag
790 move_to_reg :: (MagicId, VirtualHeapOffset {-from Node-}) -> AbstractC
791 move_to_reg (reg, offset)
792 = CAssign (CReg reg) (CVal (NodeRel offset) (kindFromMagicId reg))
795 %************************************************************************
797 \subsection[CgCase-prim-alts]{Primitive alternatives}
799 %************************************************************************
801 @cgPrimAlts@ generates a suitable @CSwitch@ for dealing with the
802 alternatives of a primitive @case@, given an addressing mode for the
803 thing to scrutinise. It also keeps track of the maximum stack depth
804 encountered down any branch.
806 As usual, no binders in the alternatives are yet bound.
812 -> [(Literal, StgExpr)] -- Alternatives
813 -> StgCaseDefault -- Default
816 cgPrimAlts gc_flag uniq ty alts deflt
817 = cgPrimAltsGivenScrutinee gc_flag scrutinee alts deflt
819 -- A temporary variable, or standard register, to hold the result
820 scrutinee = case gc_flag of
821 NoGC -> CTemp uniq kind
822 GCMayHappen -> CReg (dataReturnConvPrim kind)
824 kind = primRepFromType ty
827 cgPrimAltsGivenScrutinee gc_flag scrutinee alts deflt
828 = forkAlts (map (cgPrimAlt gc_flag) alts)
829 [{- No "extra branches" -}]
830 (cgPrimDefault gc_flag scrutinee deflt) `thenFC` \ (alt_absCs, deflt_absC) ->
831 absC (CSwitch scrutinee alt_absCs deflt_absC)
832 -- CSwitch does sensible things with one or zero alternatives
836 -> (Literal, StgExpr) -- The alternative
837 -> FCode (Literal, AbstractC) -- Its compiled form
839 cgPrimAlt gc_flag (lit, rhs)
840 = getAbsC rhs_code `thenFC` \ absC ->
843 rhs_code = possibleHeapCheck gc_flag [] False (cgExpr rhs )
845 cgPrimDefault :: GCFlag
846 -> CAddrMode -- Scrutinee
850 cgPrimDefault gc_flag scrutinee StgNoDefault
851 = panic "cgPrimDefault: No default in prim case"
853 cgPrimDefault gc_flag scrutinee (StgBindDefault _ False{-binder not used-} rhs)
854 = getAbsC (possibleHeapCheck gc_flag [] False (cgExpr rhs ))
856 cgPrimDefault gc_flag scrutinee (StgBindDefault binder True{-used-} rhs)
857 = getAbsC (possibleHeapCheck gc_flag regs False rhs_code)
859 regs = if isFollowableRep (getAmodeRep scrutinee) then
862 rhs_code = bindNewPrimToAmode binder scrutinee `thenC`
867 %************************************************************************
869 \subsection[CgCase-tidy]{Code for tidying up prior to an eval}
871 %************************************************************************
874 saveVolatileVarsAndRegs
875 :: StgLiveVars -- Vars which should be made safe
876 -> FCode (AbstractC, -- Assignments to do the saves
877 EndOfBlockInfo, -- New sequel, recording where the return
879 Maybe VirtualSpBOffset) -- Slot for current cost centre
882 saveVolatileVarsAndRegs vars
883 = saveVolatileVars vars `thenFC` \ var_saves ->
884 saveCurrentCostCentre `thenFC` \ (maybe_cc_slot, cc_save) ->
885 saveReturnAddress `thenFC` \ (new_eob_info, ret_save) ->
886 returnFC (mkAbstractCs [var_saves, cc_save, ret_save],
891 saveVolatileVars :: StgLiveVars -- Vars which should be made safe
892 -> FCode AbstractC -- Assignments to to the saves
894 saveVolatileVars vars
895 = save_em (uniqSetToList vars)
897 save_em [] = returnFC AbsCNop
900 = getCAddrModeIfVolatile var `thenFC` \ v ->
902 Nothing -> save_em vars -- Non-volatile, so carry on
905 Just vol_amode -> -- Aha! It's volatile
906 save_var var vol_amode `thenFC` \ abs_c ->
907 save_em vars `thenFC` \ abs_cs ->
908 returnFC (abs_c `mkAbsCStmts` abs_cs)
910 save_var var vol_amode
911 | isFollowableRep kind
912 = allocAStack `thenFC` \ a_slot ->
913 rebindToAStack var a_slot `thenC`
914 getSpARelOffset a_slot `thenFC` \ spa_rel ->
915 returnFC (CAssign (CVal spa_rel kind) vol_amode)
917 = allocBStack (getPrimRepSize kind) `thenFC` \ b_slot ->
918 rebindToBStack var b_slot `thenC`
919 getSpBRelOffset b_slot `thenFC` \ spb_rel ->
920 returnFC (CAssign (CVal spb_rel kind) vol_amode)
922 kind = getAmodeRep vol_amode
924 saveReturnAddress :: FCode (EndOfBlockInfo, AbstractC)
926 = getEndOfBlockInfo `thenFC` \ eob_info@(EndOfBlockInfo vA vB sequel) ->
928 -- See if it is volatile
930 InRetReg -> -- Yes, it's volatile
931 allocBStack retPrimRepSize `thenFC` \ b_slot ->
932 getSpBRelOffset b_slot `thenFC` \ spb_rel ->
934 returnFC (EndOfBlockInfo vA vB (OnStack b_slot),
935 CAssign (CVal spb_rel RetRep) (CReg RetReg))
937 UpdateCode _ -> -- It's non-volatile all right, but we still need
938 -- to allocate a B-stack slot for it, *solely* to make
939 -- sure that update frames for different values do not
940 -- appear adjacent on the B stack. This makes sure
941 -- that B-stack squeezing works ok.
943 allocBStack retPrimRepSize `thenFC` \ b_slot ->
944 returnFC (eob_info, AbsCNop)
946 other -> -- No, it's non-volatile, so do nothing
947 returnFC (eob_info, AbsCNop)
950 Note about B-stack squeezing. Consider the following:`
952 y = [...] \u [] -> ...
953 x = [y] \u [] -> case y of (a,b) -> a
955 The code for x will push an update frame, and then enter y. The code
956 for y will push another update frame. If the B-stack-squeezer then
957 wakes up, it will see two update frames right on top of each other,
958 and will combine them. This is WRONG, of course, because x's value is
961 The fix implemented above makes sure that we allocate an (unused)
962 B-stack slot before entering y. You can think of this as holding the
963 saved value of RetAddr, which (after pushing x's update frame will be
964 some update code ptr). The compiler is clever enough to load the
965 static update code ptr into RetAddr before entering ~a~, but the slot
966 is still there to separate the update frames.
968 When we save the current cost centre (which is done for lexical
969 scoping), we allocate a free B-stack location, and return (a)~the
970 virtual offset of the location, to pass on to the alternatives, and
971 (b)~the assignment to do the save (just as for @saveVolatileVars@).
974 saveCurrentCostCentre ::
975 FCode (Maybe VirtualSpBOffset, -- Where we decide to store it
976 -- Nothing if not lexical CCs
977 AbstractC) -- Assignment to save it
978 -- AbsCNop if not lexical CCs
980 saveCurrentCostCentre
981 = isSwitchSetC SccProfilingOn `thenFC` \ doing_profiling ->
982 if not doing_profiling then
983 returnFC (Nothing, AbsCNop)
985 allocBStack (getPrimRepSize CostCentreRep) `thenFC` \ b_slot ->
986 getSpBRelOffset b_slot `thenFC` \ spb_rel ->
987 returnFC (Just b_slot,
988 CAssign (CVal spb_rel CostCentreRep) (CReg CurCostCentre))
990 restoreCurrentCostCentre :: Maybe VirtualSpBOffset -> FCode AbstractC
992 restoreCurrentCostCentre Nothing
994 restoreCurrentCostCentre (Just b_slot)
995 = getSpBRelOffset b_slot `thenFC` \ spb_rel ->
996 freeBStkSlot b_slot `thenC`
997 returnFC (CCallProfCCMacro SLIT("RESTORE_CCC") [CVal spb_rel CostCentreRep])
998 -- we use the RESTORE_CCC macro, rather than just
999 -- assigning into CurCostCentre, in case RESTORE_CCC
1000 -- has some sanity-checking in it.
1004 %************************************************************************
1006 \subsection[CgCase-return-vec]{Building a return vector}
1008 %************************************************************************
1010 Build a return vector, and return a suitable label addressing
1014 mkReturnVector :: Unique
1016 -> [(ConTag, AbstractC)] -- Branch codes
1017 -> AbstractC -- Default case
1020 mkReturnVector uniq ty tagged_alt_absCs deflt_absC
1022 (return_vec_amode, vtbl_body) = case (ctrlReturnConvAlg spec_tycon) of {
1024 UnvectoredReturn _ ->
1025 (CUnVecLbl ret_label vtbl_label,
1026 absC (CRetUnVector vtbl_label
1027 (CLabelledCode ret_label
1028 (mkAlgAltsCSwitch (CReg TagReg)
1031 VectoredReturn table_size ->
1032 (CLbl vtbl_label DataPtrRep,
1033 absC (CRetVector vtbl_label
1034 -- must restore cc before each alt, if required
1035 (map mk_vector_entry [fIRST_TAG .. (table_size+fIRST_TAG-1)])
1038 -- Leave nops and comments in for now; they are eliminated
1039 -- lazily as it's printed.
1040 -- (case (nonemptyAbsC deflt_absC) of
1041 -- Nothing -> AbsCNop
1046 returnFC return_vec_amode
1050 (spec_tycon,_,_) = case (getUniDataSpecTyCon_maybe ty) of -- *must* be a real "data" type constructor
1052 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)))
1054 vtbl_label = mkVecTblLabel uniq
1055 ret_label = mkReturnPtLabel uniq
1057 mk_vector_entry :: ConTag -> Maybe CAddrMode
1059 = case [ absC | (t, absC) <- tagged_alt_absCs, t == tag ] of
1061 [absC] -> Just (CCode absC)
1062 _ -> panic "mkReturnVector: too many"
1065 %************************************************************************
1067 \subsection[CgCase-utils]{Utilities for handling case expressions}
1069 %************************************************************************
1071 @possibleHeapCheck@ tests a flag passed in to decide whether to
1072 do a heap check or not.
1075 possibleHeapCheck :: GCFlag -> [MagicId] -> Bool -> Code -> Code
1077 possibleHeapCheck GCMayHappen regs node_reqd code = heapCheck regs node_reqd code
1078 possibleHeapCheck NoGC _ _ code = code
1081 Select a restricted set of registers based on a usage mask.
1084 selectByMask [] [] = []
1085 selectByMask (True:ms) (x:xs) = x : selectByMask ms xs
1086 selectByMask (False:ms) (x:xs) = selectByMask ms xs