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_DELOOPER(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, yield )
34 import CgRetConv ( dataReturnConvAlg, dataReturnConvPrim,
36 DataReturnConvention(..), CtrlReturnConvention(..),
37 assignPrimOpResultRegs,
40 import CgStackery ( allocAStack, allocBStack, allocAStackTop, allocBStackTop )
41 import CgTailCall ( tailCallBusiness, performReturn )
42 import CgUsages ( getSpARelOffset, getSpBRelOffset, freeBStkSlot )
43 import CLabel ( mkVecTblLabel, mkReturnPtLabel, mkDefaultLabel,
46 import ClosureInfo ( mkConLFInfo, mkLFArgument, layOutDynCon )
47 import CmdLineOpts ( opt_SccProfilingOn, opt_GranMacros )
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 primOpStackRequired, StackRequirement(..)
61 import PrimRep ( getPrimRepSize, isFollowableRep, retPrimRepSize,
64 import TyCon ( isEnumerationTyCon )
65 import Type ( typePrimRep,
66 getAppSpecDataTyConExpandingDicts, maybeAppSpecDataTyConExpandingDicts,
69 import Util ( sortLt, isIn, isn'tIn, zipEqual,
70 pprError, panic, assertPanic
76 = GCMayHappen -- The scrutinee may involve GC, so everything must be
77 -- tidy before the code for the scrutinee.
79 | NoGC -- The scrutinee is a primitive value, or a call to a
80 -- primitive op which does no GC. Hence the case can
81 -- be done inline, without tidying up first.
84 It is quite interesting to decide whether to put a heap-check
85 at the start of each alternative. Of course we certainly have
86 to do so if the case forces an evaluation, or if there is a primitive
87 op which can trigger GC.
89 A more interesting situation is this:
96 default -> !C!; ...C...
99 where \tr{!x!} indicates a possible heap-check point. The heap checks
100 in the alternatives {\em can} be omitted, in which case the topmost
101 heapcheck will take their worst case into account.
103 In favour of omitting \tr{!B!}, \tr{!C!}:
107 {\em May} save a heap overflow test,
108 if ...A... allocates anything. The other advantage
109 of this is that we can use relative addressing
110 from a single Hp to get at all the closures so allocated.
112 No need to save volatile vars etc across the case
119 May do more allocation than reqd. This sometimes bites us
120 badly. For example, nfib (ha!) allocates about 30\% more space if the
121 worst-casing is done, because many many calls to nfib are leaf calls
122 which don't need to allocate anything.
124 This never hurts us if there is only one alternative.
128 *** NOT YET DONE *** The difficulty is that \tr{!B!}, \tr{!C!} need
129 to take account of what is live, and that includes all live volatile
130 variables, even if they also have stable analogues. Furthermore, the
131 stack pointers must be lined up properly so that GC sees tidy stacks.
132 If these things are done, then the heap checks can be done at \tr{!B!} and
133 \tr{!C!} without a full save-volatile-vars sequence.
144 Several special cases for primitive operations.
146 ******* TO DO TO DO: fix what follows
150 case (op x1 ... xn) of
153 where the type of the case scrutinee is a multi-constuctor algebraic type.
154 Then we simply compile code for
162 case (op x1 ... xn) of
166 where the type of the case scrutinee is a multi-constuctor algebraic type.
167 we just bomb out at the moment. It never happens in practice.
169 **** END OF TO DO TO DO
172 cgCase scrut@(StgPrim op args _) live_in_whole_case live_in_alts uniq
173 (StgAlgAlts _ alts (StgBindDefault id _ deflt_rhs))
174 = if not (null alts) then
175 panic "cgCase: case on PrimOp with default *and* alts\n"
176 -- For now, die if alts are non-empty
178 cgExpr (StgLet (StgNonRec id scrut_rhs) deflt_rhs)
180 scrut_rhs = StgRhsClosure useCurrentCostCentre stgArgOcc{-safe-} scrut_free_vars
182 scrut_free_vars = [ fv | StgVarArg fv <- args, not (toplevelishId fv) ]
188 cgCase (StgPrim op args _) live_in_whole_case live_in_alts uniq alts
189 | not (primOpCanTriggerGC op)
191 -- Get amodes for the arguments and results
192 getPrimOpArgAmodes op args `thenFC` \ arg_amodes ->
194 result_amodes = getPrimAppResultAmodes uniq alts
195 liveness_mask = panic "cgCase: liveness of non-GC-ing primop touched\n"
197 -- Perform the operation
198 getVolatileRegs live_in_alts `thenFC` \ vol_regs ->
200 -- seq cannot happen here => no additional B Stack alloc
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 -- Allocate stack words for the prim-op itself,
235 -- these are guaranteed to be ON TOP OF the stack.
236 -- Currently this is used *only* by the seq# primitive op.
238 (a_req,b_req) = case (primOpStackRequired op) of
239 NoStackRequired -> (0, 0)
240 FixedStackRequired a b -> (a, b)
241 VariableStackRequired -> (0, 0) -- i.e. don't care
243 allocAStackTop a_req `thenFC` \ a_slot ->
244 allocBStackTop b_req `thenFC` \ b_slot ->
246 getEndOfBlockInfo `thenFC` \ eob_info@(EndOfBlockInfo args_spa args_spb sequel) ->
247 -- a_req and b_req allocate stack space that is taken care of by the
248 -- macros generated for the primops; thus, we there is no need to adjust
249 -- this part of the stacks later on (=> +a_req in EndOfBlockInfo)
250 -- currently all this is only used for SeqOp
251 forkEval (if True {- a_req==0 && b_req==0 -}
253 else (EndOfBlockInfo (args_spa+a_req)
254 (args_spb+b_req) sequel)) nopC
256 getAbsC (cgInlineAlts GCMayHappen uniq alts) `thenFC` \ abs_c ->
257 absC (CRetUnVector vtbl_label (CLabelledCode return_label abs_c))
259 returnFC (CaseAlts (CUnVecLbl return_label vtbl_label)
260 Nothing{-no semi-tagging-}))
261 `thenFC` \ new_eob_info ->
263 -- Record the continuation info
264 setEndOfBlockInfo new_eob_info (
266 -- Now "return" to the inline alternatives; this will get
267 -- compiled to a fall-through.
269 simultaneous_assts = arg_assts `mkAbsCStmts` volatile_var_save_assts
271 -- do_op_and_continue will be passed an amode for the continuation
272 do_op_and_continue sequel
273 = absC (COpStmt op_result_amodes
275 (pin_liveness op liveness_arg op_arg_amodes)
280 sequelToAmode sequel `thenFC` \ dest_amode ->
281 absC (CReturn dest_amode DirectReturn)
283 -- Note: we CJump even for algebraic data types,
284 -- because cgInlineAlts always generates code, never a
287 performReturn simultaneous_assts do_op_and_continue live_in_alts
290 -- for all PrimOps except ccalls, we pin the liveness info
291 -- on as the first "argument"
292 -- ToDo: un-duplicate?
294 pin_liveness (CCallOp _ _ _ _ _) _ args = args
295 pin_liveness other_op liveness_arg args
298 vtbl_label = mkVecTblLabel uniq
299 return_label = mkReturnPtLabel uniq
303 Another special case: scrutinising a primitive-typed variable. No
304 evaluation required. We don't save volatile variables, nor do we do a
305 heap-check in the alternatives. Instead, the heap usage of the
306 alternatives is worst-cased and passed upstream. This can result in
307 allocating more heap than strictly necessary, but it will sometimes
308 eliminate a heap check altogether.
311 cgCase (StgApp v [] _) live_in_whole_case live_in_alts uniq (StgPrimAlts ty alts deflt)
312 = getArgAmode v `thenFC` \ amode ->
313 cgPrimAltsGivenScrutinee NoGC amode alts deflt
316 Special case: scrutinising a non-primitive variable.
317 This can be done a little better than the general case, because
318 we can reuse/trim the stack slot holding the variable (if it is in one).
321 cgCase (StgApp (StgVarArg fun) args _ {-lvs must be same as live_in_alts-})
322 live_in_whole_case live_in_alts uniq alts@(StgAlgAlts _ _ _)
324 getCAddrModeAndInfo fun `thenFC` \ (fun_amode, lf_info) ->
325 getArgAmodes args `thenFC` \ arg_amodes ->
327 -- Squish the environment
328 nukeDeadBindings live_in_alts `thenC`
329 saveVolatileVarsAndRegs live_in_alts
330 `thenFC` \ (save_assts, alts_eob_info, maybe_cc_slot) ->
332 forkEval alts_eob_info
333 nopC (cgEvalAlts maybe_cc_slot uniq alts) `thenFC` \ scrut_eob_info ->
334 setEndOfBlockInfo scrut_eob_info (
335 tailCallBusiness fun fun_amode lf_info arg_amodes live_in_alts save_assts
340 Finally, here is the general case.
343 cgCase expr live_in_whole_case live_in_alts uniq alts
344 = -- Figure out what volatile variables to save
345 nukeDeadBindings live_in_whole_case `thenC`
346 saveVolatileVarsAndRegs live_in_alts
347 `thenFC` \ (save_assts, alts_eob_info, maybe_cc_slot) ->
349 -- Save those variables right now!
350 absC save_assts `thenC`
352 forkEval alts_eob_info
353 (nukeDeadBindings live_in_alts)
354 (cgEvalAlts maybe_cc_slot uniq alts) `thenFC` \ scrut_eob_info ->
356 setEndOfBlockInfo scrut_eob_info (cgExpr expr)
359 %************************************************************************
361 \subsection[CgCase-primops]{Primitive applications}
363 %************************************************************************
365 Get result amodes for a primitive operation, in the case wher GC can't happen.
366 The amodes are returned in canonical order, ready for the prim-op!
368 Alg case: temporaries named as in the alternatives,
369 plus (CTemp u) for the tag (if needed)
372 This is all disgusting, because these amodes must be consistent with those
373 invented by CgAlgAlts.
376 getPrimAppResultAmodes
383 -- If there's an StgBindDefault which does use the bound
384 -- variable, then we can only handle it if the type involved is
385 -- an enumeration type. That's important in the case
391 -- The only reason for the restriction to *enumeration* types is our
392 -- inability to invent suitable temporaries to hold the results;
393 -- Elaborating the CTemp addr mode to have a second uniq field
394 -- (which would simply count from 1) would solve the problem.
395 -- Anyway, cgInlineAlts is now capable of handling all cases;
396 -- it's only this function which is being wimpish.
398 getPrimAppResultAmodes uniq (StgAlgAlts ty alts (StgBindDefault _ True {- used -} _))
399 | isEnumerationTyCon spec_tycon = [tag_amode]
400 | otherwise = panic "getPrimAppResultAmodes: non-enumeration algebraic alternatives with default"
402 -- A temporary variable to hold the tag; this is unaffected by GC because
403 -- the heap-checks in the branches occur after the switch
404 tag_amode = CTemp uniq IntRep
405 (spec_tycon, _, _) = getAppSpecDataTyConExpandingDicts ty
407 getPrimAppResultAmodes uniq (StgAlgAlts ty alts other_default)
408 -- Default is either StgNoDefault or StgBindDefault with unused binder
410 [_] -> arg_amodes -- No need for a tag
411 other -> tag_amode : arg_amodes
413 -- A temporary variable to hold the tag; this is unaffected by GC because
414 -- the heap-checks in the branches occur after the switch
415 tag_amode = CTemp uniq IntRep
417 -- Sort alternatives into canonical order; there must be a complete
418 -- set because there's no default case.
419 sorted_alts = sortLt lt alts
420 (con1,_,_,_) `lt` (con2,_,_,_) = dataConTag con1 < dataConTag con2
422 arg_amodes :: [CAddrMode]
424 -- Turn them into amodes
425 arg_amodes = concat (map mk_amodes sorted_alts)
426 mk_amodes (con, args, use_mask, rhs)
427 = [ CTemp (uniqueOf arg) (idPrimRep arg) | arg <- args ]
430 The situation is simpler for primitive
431 results, because there is only one!
434 getPrimAppResultAmodes uniq (StgPrimAlts ty _ _)
435 = [CTemp uniq (typePrimRep ty)]
439 %************************************************************************
441 \subsection[CgCase-alts]{Alternatives}
443 %************************************************************************
445 @cgEvalAlts@ returns an addressing mode for a continuation for the
446 alternatives of a @case@, used in a context when there
447 is some evaluation to be done.
450 cgEvalAlts :: Maybe VirtualSpBOffset -- Offset of cost-centre to be restored, if any
453 -> FCode Sequel -- Any addr modes inside are guaranteed to be a label
454 -- so that we can duplicate it without risk of
457 cgEvalAlts cc_slot uniq (StgAlgAlts ty alts deflt)
458 = -- Generate the instruction to restore cost centre, if any
459 restoreCurrentCostCentre cc_slot `thenFC` \ cc_restore ->
461 -- Generate sequel info for use downstream
462 -- At the moment, we only do it if the type is vector-returnable.
463 -- Reason: if not, then it costs extra to label the
464 -- alternatives, because we'd get return code like:
466 -- switch TagReg { 0 : JMP(alt_1); 1 : JMP(alt_2) ..etc }
468 -- which is worse than having the alt code in the switch statement
471 (spec_tycon, _, _) = getAppSpecDataTyConExpandingDicts ty
474 = case ctrlReturnConvAlg spec_tycon of
475 VectoredReturn _ -> True
479 = if not use_labelled_alts then
480 Nothing -- no semi-tagging info
482 cgSemiTaggedAlts uniq alts deflt -- Just <something>
484 cgAlgAlts GCMayHappen uniq cc_restore use_labelled_alts ty alts deflt True
485 `thenFC` \ (tagged_alt_absCs, deflt_absC) ->
487 mkReturnVector uniq ty tagged_alt_absCs deflt_absC `thenFC` \ return_vec ->
489 returnFC (CaseAlts return_vec semi_tagged_stuff)
491 cgEvalAlts cc_slot uniq (StgPrimAlts ty alts deflt)
492 = -- Generate the instruction to restore cost centre, if any
493 restoreCurrentCostCentre cc_slot `thenFC` \ cc_restore ->
495 -- Generate the switch
496 getAbsC (cgPrimAlts GCMayHappen uniq ty alts deflt) `thenFC` \ abs_c ->
498 -- Generate the labelled block, starting with restore-cost-centre
499 absC (CRetUnVector vtbl_label
500 (CLabelledCode return_label (cc_restore `mkAbsCStmts` abs_c)))
502 -- Return an amode for the block
503 returnFC (CaseAlts (CUnVecLbl return_label vtbl_label) Nothing{-no semi-tagging-})
505 vtbl_label = mkVecTblLabel uniq
506 return_label = mkReturnPtLabel uniq
511 cgInlineAlts :: GCFlag -> Unique
516 HWL comment on {\em GrAnSim\/} (adding GRAN_YIELDs for context switch): If
517 we do an inlining of the case no separate functions for returning are
518 created, so we don't have to generate a GRAN_YIELD in that case. This info
519 must be propagated to cgAlgAltRhs (where the GRAN_YIELD macro might be
520 emitted). Hence, the new Bool arg to cgAlgAltRhs.
522 First case: algebraic case, exactly one alternative, no default.
523 In this case the primitive op will not have set a temporary to the
524 tag, so we shouldn't generate a switch statment. Instead we just
528 cgInlineAlts gc_flag uniq (StgAlgAlts ty [alt@(con,args,use_mask,rhs)] StgNoDefault)
529 = cgAlgAltRhs gc_flag con args use_mask rhs False{-no yield macro if alt gets inlined-}
532 Second case: algebraic case, several alternatives.
533 Tag is held in a temporary.
536 cgInlineAlts gc_flag uniq (StgAlgAlts ty alts deflt)
537 = cgAlgAlts gc_flag uniq AbsCNop{-restore_cc-} False{-no semi-tagging-}
539 False{-don't emit yield-} `thenFC` \ (tagged_alts, deflt_c) ->
542 absC (mkAlgAltsCSwitch tag_amode tagged_alts deflt_c)
544 -- A temporary variable to hold the tag; this is unaffected by GC because
545 -- the heap-checks in the branches occur after the switch
546 tag_amode = CTemp uniq IntRep
549 Third (real) case: primitive result type.
552 cgInlineAlts gc_flag uniq (StgPrimAlts ty alts deflt)
553 = cgPrimAlts gc_flag uniq ty alts deflt
557 %************************************************************************
559 \subsection[CgCase-alg-alts]{Algebraic alternatives}
561 %************************************************************************
563 In @cgAlgAlts@, none of the binders in the alternatives are
564 assumed to be yet bound.
566 HWL comment on {\em GrAnSim\/} (adding GRAN_YIELDs for context switch): The
567 last arg of cgAlgAlts indicates if we want a context switch at the
568 beginning of each alternative. Normally we want that. The only exception
569 are inlined alternatives.
574 -> AbstractC -- Restore-cost-centre instruction
575 -> Bool -- True <=> branches must be labelled
576 -> Type -- From the case statement
577 -> [(Id, [Id], [Bool], StgExpr)] -- The alternatives
578 -> StgCaseDefault -- The default
579 -> Bool -- Context switch at alts?
580 -> FCode ([(ConTag, AbstractC)], -- The branches
581 AbstractC -- The default case
585 The case with a default which has a binder is different. We need to
586 pick all the constructors which aren't handled explicitly by an
587 alternative, and which return their results in registers, allocate
588 them explicitly in the heap, and jump to a join point for the default
591 OLD: All of this only works if a heap-check is required anyway, because
592 otherwise it isn't safe to allocate.
594 NEW (July 94): now false! It should work regardless of gc_flag,
595 because of the extra_branches argument now added to forkAlts.
597 We put a heap-check at the join point, for the benefit of constructors
598 which don't need to do allocation. This means that ones which do need
599 to allocate may end up doing two heap-checks; but that's just too bad.
600 (We'd need two join labels otherwise. ToDo.)
602 It's all pretty turgid anyway.
605 cgAlgAlts gc_flag uniq restore_cc semi_tagging
606 ty alts deflt@(StgBindDefault binder True{-used-} _)
607 emit_yield{-should a yield macro be emitted?-}
609 extra_branches :: [FCode (ConTag, AbstractC)]
610 extra_branches = catMaybes (map mk_extra_branch default_cons)
612 must_label_default = semi_tagging || not (null extra_branches)
614 forkAlts (map (cgAlgAlt gc_flag uniq restore_cc semi_tagging emit_yield) alts)
616 (cgAlgDefault gc_flag uniq restore_cc must_label_default deflt emit_yield)
619 default_join_lbl = mkDefaultLabel uniq
620 jump_instruction = CJump (CLbl default_join_lbl CodePtrRep)
622 (spec_tycon, _, spec_cons) = getAppSpecDataTyConExpandingDicts ty
624 alt_cons = [ con | (con,_,_,_) <- alts ]
626 default_cons = [ spec_con | spec_con <- spec_cons, -- In this type
627 spec_con `not_elem` alt_cons ] -- Not handled explicitly
629 not_elem = isn'tIn "cgAlgAlts"
631 -- (mk_extra_branch con) returns the a maybe for the extra branch for con.
632 -- The "maybe" is because con may return in heap, in which case there is
633 -- nothing to do. Otherwise, we have a special case for a nullary constructor,
634 -- but in the general case we do an allocation and heap-check.
636 mk_extra_branch :: DataCon -> (Maybe (FCode (ConTag, AbstractC)))
639 = ASSERT(isDataCon con)
640 case dataReturnConvAlg con of
641 ReturnInHeap -> Nothing
642 ReturnInRegs rs -> Just (getAbsC (alloc_code rs) `thenFC` \ abs_c ->
643 returnFC (tag, abs_c)
646 lf_info = mkConLFInfo con
649 -- alloc_code generates code to allocate constructor con, whose args are
650 -- in the arguments to alloc_code, assigning the result to Node.
651 alloc_code :: [MagicId] -> Code
654 = possibleHeapCheck gc_flag regs False (
655 buildDynCon binder useCurrentCostCentre con
656 (map CReg regs) (all zero_size regs)
658 idInfoToAmode PtrRep idinfo `thenFC` \ amode ->
660 absC (CAssign (CReg node) amode) `thenC`
661 absC jump_instruction
664 zero_size reg = getPrimRepSize (magicIdPrimRep reg) == 0
667 Now comes the general case
670 cgAlgAlts gc_flag uniq restore_cc must_label_branches ty alts deflt
671 {- The deflt is either StgNoDefault or a BindDefault which doesn't use the binder -}
672 emit_yield{-should a yield macro be emitted?-}
674 = forkAlts (map (cgAlgAlt gc_flag uniq restore_cc must_label_branches emit_yield) alts)
675 [{- No "extra branches" -}]
676 (cgAlgDefault gc_flag uniq restore_cc must_label_branches deflt emit_yield)
680 cgAlgDefault :: GCFlag
681 -> Unique -> AbstractC -> Bool -- turgid state...
682 -> StgCaseDefault -- input
684 -> FCode AbstractC -- output
686 cgAlgDefault gc_flag uniq restore_cc must_label_branch
690 cgAlgDefault gc_flag uniq restore_cc must_label_branch
691 (StgBindDefault _ False{-binder not used-} rhs)
692 emit_yield{-should a yield macro be emitted?-}
694 = getAbsC (absC restore_cc `thenC`
696 emit_gran_macros = opt_GranMacros
698 (if emit_gran_macros && emit_yield
700 else absC AbsCNop) `thenC`
701 -- liveness same as in possibleHeapCheck below
702 possibleHeapCheck gc_flag [] False (cgExpr rhs)) `thenFC` \ abs_c ->
704 final_abs_c | must_label_branch = CJump (CLabelledCode lbl abs_c)
709 lbl = mkDefaultLabel uniq
712 cgAlgDefault gc_flag uniq restore_cc must_label_branch
713 (StgBindDefault binder True{-binder used-} rhs)
714 emit_yield{-should a yield macro be emitted?-}
716 = -- We have arranged that Node points to the thing, even
717 -- even if we return in registers
718 bindNewToReg binder node mkLFArgument `thenC`
719 getAbsC (absC restore_cc `thenC`
721 emit_gran_macros = opt_GranMacros
723 (if emit_gran_macros && emit_yield
724 then yield [node] False
725 else absC AbsCNop) `thenC`
726 -- liveness same as in possibleHeapCheck below
727 possibleHeapCheck gc_flag [node] False (cgExpr rhs)
728 -- Node is live, but doesn't need to point at the thing itself;
729 -- it's ok for Node to point to an indirection or FETCH_ME
730 -- Hence no need to re-enter Node.
731 ) `thenFC` \ abs_c ->
734 final_abs_c | must_label_branch = CJump (CLabelledCode lbl abs_c)
739 lbl = mkDefaultLabel uniq
741 -- HWL comment on GrAnSim: GRAN_YIELDs needed; emitted in cgAlgAltRhs
744 -> Unique -> AbstractC -> Bool -- turgid state
745 -> Bool -- Context switch at alts?
746 -> (Id, [Id], [Bool], StgExpr)
747 -> FCode (ConTag, AbstractC)
749 cgAlgAlt gc_flag uniq restore_cc must_label_branch
750 emit_yield{-should a yield macro be emitted?-}
751 (con, args, use_mask, rhs)
752 = getAbsC (absC restore_cc `thenC`
753 cgAlgAltRhs gc_flag con args use_mask rhs
755 ) `thenFC` \ abs_c ->
757 final_abs_c | must_label_branch = CJump (CLabelledCode lbl abs_c)
760 returnFC (tag, final_abs_c)
763 lbl = mkAltLabel uniq tag
765 cgAlgAltRhs :: GCFlag
770 -> Bool -- context switch?
772 cgAlgAltRhs gc_flag con args use_mask rhs emit_yield
774 (live_regs, node_reqd)
775 = case (dataReturnConvAlg con) of
776 ReturnInHeap -> ([], True)
777 ReturnInRegs regs -> ([reg | (reg,True) <- zipEqual "cgAlgAltRhs" regs use_mask], False)
778 -- Pick the live registers using the use_mask
779 -- Doing so is IMPORTANT, because with semi-tagging
780 -- enabled only the live registers will have valid
784 emit_gran_macros = opt_GranMacros
786 (if emit_gran_macros && emit_yield
787 then yield live_regs node_reqd
788 else absC AbsCNop) `thenC`
789 -- liveness same as in possibleHeapCheck below
790 possibleHeapCheck gc_flag live_regs node_reqd (
792 NoGC -> mapFCs bindNewToTemp args `thenFC` \ _ ->
794 GCMayHappen -> bindConArgs con args
800 %************************************************************************
802 \subsection[CgCase-semi-tagged-alts]{The code to deal with sem-tagging}
804 %************************************************************************
806 Turgid-but-non-monadic code to conjure up the required info from
807 algebraic case alternatives for semi-tagging.
810 cgSemiTaggedAlts :: Unique
811 -> [(Id, [Id], [Bool], StgExpr)]
812 -> GenStgCaseDefault Id Id
815 cgSemiTaggedAlts uniq alts deflt
816 = Just (map st_alt alts, st_deflt deflt)
818 st_deflt StgNoDefault = Nothing
820 st_deflt (StgBindDefault binder binder_used _)
821 = Just (if binder_used then Just binder else Nothing,
822 (CCallProfCtrMacro SLIT("RET_SEMI_BY_DEFAULT") [], -- ToDo: monadise?
826 st_alt (con, args, use_mask, _)
827 = case (dataReturnConvAlg con) of
830 -- Ha! Nothing to do; Node already points to the thing
832 (CCallProfCtrMacro SLIT("RET_SEMI_IN_HEAP") -- ToDo: monadise?
833 [mkIntCLit (length args)], -- how big the thing in the heap is
838 -- We have to load the live registers from the constructor
839 -- pointed to by Node.
841 (_, regs_w_offsets) = layOutDynCon con magicIdPrimRep regs
843 used_regs = selectByMask use_mask regs
845 used_regs_w_offsets = [ ro | ro@(reg,offset) <- regs_w_offsets,
846 reg `is_elem` used_regs]
848 is_elem = isIn "cgSemiTaggedAlts"
852 CCallProfCtrMacro SLIT("RET_SEMI_IN_REGS") -- ToDo: macroise?
853 [mkIntCLit (length regs_w_offsets),
854 mkIntCLit (length used_regs_w_offsets)],
855 CSimultaneous (mkAbstractCs (map move_to_reg used_regs_w_offsets))],
858 con_tag = dataConTag con
859 join_label = mkAltLabel uniq con_tag
861 move_to_reg :: (MagicId, VirtualHeapOffset {-from Node-}) -> AbstractC
862 move_to_reg (reg, offset)
863 = CAssign (CReg reg) (CVal (NodeRel offset) (magicIdPrimRep reg))
866 %************************************************************************
868 \subsection[CgCase-prim-alts]{Primitive alternatives}
870 %************************************************************************
872 @cgPrimAlts@ generates a suitable @CSwitch@ for dealing with the
873 alternatives of a primitive @case@, given an addressing mode for the
874 thing to scrutinise. It also keeps track of the maximum stack depth
875 encountered down any branch.
877 As usual, no binders in the alternatives are yet bound.
883 -> [(Literal, StgExpr)] -- Alternatives
884 -> StgCaseDefault -- Default
887 cgPrimAlts gc_flag uniq ty alts deflt
888 = cgPrimAltsGivenScrutinee gc_flag scrutinee alts deflt
890 -- A temporary variable, or standard register, to hold the result
891 scrutinee = case gc_flag of
892 NoGC -> CTemp uniq kind
893 GCMayHappen -> CReg (dataReturnConvPrim kind)
895 kind = typePrimRep ty
898 cgPrimAltsGivenScrutinee gc_flag scrutinee alts deflt
899 = forkAlts (map (cgPrimAlt gc_flag) alts)
900 [{- No "extra branches" -}]
901 (cgPrimDefault gc_flag scrutinee deflt) `thenFC` \ (alt_absCs, deflt_absC) ->
902 absC (CSwitch scrutinee alt_absCs deflt_absC)
903 -- CSwitch does sensible things with one or zero alternatives
907 -> (Literal, StgExpr) -- The alternative
908 -> FCode (Literal, AbstractC) -- Its compiled form
910 cgPrimAlt gc_flag (lit, rhs)
911 = getAbsC rhs_code `thenFC` \ absC ->
914 rhs_code = possibleHeapCheck gc_flag [] False (cgExpr rhs )
916 cgPrimDefault :: GCFlag
917 -> CAddrMode -- Scrutinee
921 cgPrimDefault gc_flag scrutinee StgNoDefault
922 = panic "cgPrimDefault: No default in prim case"
924 cgPrimDefault gc_flag scrutinee (StgBindDefault _ False{-binder not used-} rhs)
925 = getAbsC (possibleHeapCheck gc_flag [] False (cgExpr rhs ))
927 cgPrimDefault gc_flag scrutinee (StgBindDefault binder True{-used-} rhs)
928 = getAbsC (possibleHeapCheck gc_flag regs False rhs_code)
930 regs = if isFollowableRep (getAmodeRep scrutinee) then
933 rhs_code = bindNewPrimToAmode binder scrutinee `thenC`
938 %************************************************************************
940 \subsection[CgCase-tidy]{Code for tidying up prior to an eval}
942 %************************************************************************
945 saveVolatileVarsAndRegs
946 :: StgLiveVars -- Vars which should be made safe
947 -> FCode (AbstractC, -- Assignments to do the saves
948 EndOfBlockInfo, -- New sequel, recording where the return
950 Maybe VirtualSpBOffset) -- Slot for current cost centre
953 saveVolatileVarsAndRegs vars
954 = saveVolatileVars vars `thenFC` \ var_saves ->
955 saveCurrentCostCentre `thenFC` \ (maybe_cc_slot, cc_save) ->
956 saveReturnAddress `thenFC` \ (new_eob_info, ret_save) ->
957 returnFC (mkAbstractCs [var_saves, cc_save, ret_save],
962 saveVolatileVars :: StgLiveVars -- Vars which should be made safe
963 -> FCode AbstractC -- Assignments to to the saves
965 saveVolatileVars vars
966 = save_em (idSetToList vars)
968 save_em [] = returnFC AbsCNop
971 = getCAddrModeIfVolatile var `thenFC` \ v ->
973 Nothing -> save_em vars -- Non-volatile, so carry on
976 Just vol_amode -> -- Aha! It's volatile
977 save_var var vol_amode `thenFC` \ abs_c ->
978 save_em vars `thenFC` \ abs_cs ->
979 returnFC (abs_c `mkAbsCStmts` abs_cs)
981 save_var var vol_amode
982 | isFollowableRep kind
983 = allocAStack `thenFC` \ a_slot ->
984 rebindToAStack var a_slot `thenC`
985 getSpARelOffset a_slot `thenFC` \ spa_rel ->
986 returnFC (CAssign (CVal spa_rel kind) vol_amode)
988 = allocBStack (getPrimRepSize kind) `thenFC` \ b_slot ->
989 rebindToBStack var b_slot `thenC`
990 getSpBRelOffset b_slot `thenFC` \ spb_rel ->
991 returnFC (CAssign (CVal spb_rel kind) vol_amode)
993 kind = getAmodeRep vol_amode
995 saveReturnAddress :: FCode (EndOfBlockInfo, AbstractC)
997 = getEndOfBlockInfo `thenFC` \ eob_info@(EndOfBlockInfo vA vB sequel) ->
999 -- See if it is volatile
1001 InRetReg -> -- Yes, it's volatile
1002 allocBStack retPrimRepSize `thenFC` \ b_slot ->
1003 getSpBRelOffset b_slot `thenFC` \ spb_rel ->
1005 returnFC (EndOfBlockInfo vA vB (OnStack b_slot),
1006 CAssign (CVal spb_rel RetRep) (CReg RetReg))
1008 UpdateCode _ -> -- It's non-volatile all right, but we still need
1009 -- to allocate a B-stack slot for it, *solely* to make
1010 -- sure that update frames for different values do not
1011 -- appear adjacent on the B stack. This makes sure
1012 -- that B-stack squeezing works ok.
1014 allocBStack retPrimRepSize `thenFC` \ b_slot ->
1015 returnFC (eob_info, AbsCNop)
1017 other -> -- No, it's non-volatile, so do nothing
1018 returnFC (eob_info, AbsCNop)
1021 Note about B-stack squeezing. Consider the following:`
1023 y = [...] \u [] -> ...
1024 x = [y] \u [] -> case y of (a,b) -> a
1026 The code for x will push an update frame, and then enter y. The code
1027 for y will push another update frame. If the B-stack-squeezer then
1028 wakes up, it will see two update frames right on top of each other,
1029 and will combine them. This is WRONG, of course, because x's value is
1030 not the same as y's.
1032 The fix implemented above makes sure that we allocate an (unused)
1033 B-stack slot before entering y. You can think of this as holding the
1034 saved value of RetAddr, which (after pushing x's update frame will be
1035 some update code ptr). The compiler is clever enough to load the
1036 static update code ptr into RetAddr before entering ~a~, but the slot
1037 is still there to separate the update frames.
1039 When we save the current cost centre (which is done for lexical
1040 scoping), we allocate a free B-stack location, and return (a)~the
1041 virtual offset of the location, to pass on to the alternatives, and
1042 (b)~the assignment to do the save (just as for @saveVolatileVars@).
1045 saveCurrentCostCentre ::
1046 FCode (Maybe VirtualSpBOffset, -- Where we decide to store it
1047 -- Nothing if not lexical CCs
1048 AbstractC) -- Assignment to save it
1049 -- AbsCNop if not lexical CCs
1051 saveCurrentCostCentre
1053 doing_profiling = opt_SccProfilingOn
1055 if not doing_profiling then
1056 returnFC (Nothing, AbsCNop)
1058 allocBStack (getPrimRepSize CostCentreRep) `thenFC` \ b_slot ->
1059 getSpBRelOffset b_slot `thenFC` \ spb_rel ->
1060 returnFC (Just b_slot,
1061 CAssign (CVal spb_rel CostCentreRep) (CReg CurCostCentre))
1063 restoreCurrentCostCentre :: Maybe VirtualSpBOffset -> FCode AbstractC
1065 restoreCurrentCostCentre Nothing
1067 restoreCurrentCostCentre (Just b_slot)
1068 = getSpBRelOffset b_slot `thenFC` \ spb_rel ->
1069 freeBStkSlot b_slot `thenC`
1070 returnFC (CCallProfCCMacro SLIT("RESTORE_CCC") [CVal spb_rel CostCentreRep])
1071 -- we use the RESTORE_CCC macro, rather than just
1072 -- assigning into CurCostCentre, in case RESTORE_CCC
1073 -- has some sanity-checking in it.
1077 %************************************************************************
1079 \subsection[CgCase-return-vec]{Building a return vector}
1081 %************************************************************************
1083 Build a return vector, and return a suitable label addressing
1087 mkReturnVector :: Unique
1089 -> [(ConTag, AbstractC)] -- Branch codes
1090 -> AbstractC -- Default case
1093 mkReturnVector uniq ty tagged_alt_absCs deflt_absC
1095 (return_vec_amode, vtbl_body) = case (ctrlReturnConvAlg spec_tycon) of {
1097 UnvectoredReturn _ ->
1098 (CUnVecLbl ret_label vtbl_label,
1099 absC (CRetUnVector vtbl_label
1100 (CLabelledCode ret_label
1101 (mkAlgAltsCSwitch (CReg TagReg)
1104 VectoredReturn table_size ->
1105 (CLbl vtbl_label DataPtrRep,
1106 absC (CRetVector vtbl_label
1107 -- must restore cc before each alt, if required
1108 (map mk_vector_entry [fIRST_TAG .. (table_size+fIRST_TAG-1)])
1111 -- Leave nops and comments in for now; they are eliminated
1112 -- lazily as it's printed.
1113 -- (case (nonemptyAbsC deflt_absC) of
1114 -- Nothing -> AbsCNop
1119 returnFC return_vec_amode
1123 (spec_tycon,_,_) = case (maybeAppSpecDataTyConExpandingDicts ty) of -- *must* be a real "data" type constructor
1125 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)
1127 vtbl_label = mkVecTblLabel uniq
1128 ret_label = mkReturnPtLabel uniq
1130 mk_vector_entry :: ConTag -> Maybe CAddrMode
1132 = case [ absC | (t, absC) <- tagged_alt_absCs, t == tag ] of
1134 [absC] -> Just (CCode absC)
1135 _ -> panic "mkReturnVector: too many"
1138 %************************************************************************
1140 \subsection[CgCase-utils]{Utilities for handling case expressions}
1142 %************************************************************************
1144 @possibleHeapCheck@ tests a flag passed in to decide whether to
1145 do a heap check or not.
1148 possibleHeapCheck :: GCFlag -> [MagicId] -> Bool -> Code -> Code
1150 possibleHeapCheck GCMayHappen regs node_reqd code = heapCheck regs node_reqd code
1151 possibleHeapCheck NoGC _ _ code = code
1154 Select a restricted set of registers based on a usage mask.
1157 selectByMask [] [] = []
1158 selectByMask (True:ms) (x:xs) = x : selectByMask ms xs
1159 selectByMask (False:ms) (x:xs) = selectByMask ms xs