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, CostCentre )
49 import HeapOffs ( SYN_IE(VirtualSpBOffset), SYN_IE(VirtualHeapOffset) )
50 import Id ( idPrimRep, toplevelishId,
51 dataConTag, fIRST_TAG, SYN_IE(ConTag),
52 isDataCon, SYN_IE(DataCon),
53 idSetToList, GenId{-instance Uniquable,Eq-}, SYN_IE(Id)
55 import Literal ( Literal )
56 import Maybes ( catMaybes )
57 import Outputable ( Outputable(..) )
58 import PprStyle ( PprStyle(..) )
59 import PprType ( GenType{-instance Outputable-} )
61 import PrimOp ( primOpCanTriggerGC, PrimOp(..),
62 primOpStackRequired, StackRequirement(..)
64 import PrimRep ( getPrimRepSize, isFollowableRep, retPrimRepSize,
67 import TyCon ( isEnumerationTyCon )
68 import Type ( typePrimRep,
69 getAppSpecDataTyConExpandingDicts,
70 maybeAppSpecDataTyConExpandingDicts,
73 import Unique ( Unique )
74 import UniqFM ( Uniquable(..) )
75 import Util ( sortLt, isIn, isn'tIn, zipEqual,
76 pprError, panic, assertPanic
83 = GCMayHappen -- The scrutinee may involve GC, so everything must be
84 -- tidy before the code for the scrutinee.
86 | NoGC -- The scrutinee is a primitive value, or a call to a
87 -- primitive op which does no GC. Hence the case can
88 -- be done inline, without tidying up first.
91 It is quite interesting to decide whether to put a heap-check
92 at the start of each alternative. Of course we certainly have
93 to do so if the case forces an evaluation, or if there is a primitive
94 op which can trigger GC.
96 A more interesting situation is this:
103 default -> !C!; ...C...
106 where \tr{!x!} indicates a possible heap-check point. The heap checks
107 in the alternatives {\em can} be omitted, in which case the topmost
108 heapcheck will take their worst case into account.
110 In favour of omitting \tr{!B!}, \tr{!C!}:
114 {\em May} save a heap overflow test,
115 if ...A... allocates anything. The other advantage
116 of this is that we can use relative addressing
117 from a single Hp to get at all the closures so allocated.
119 No need to save volatile vars etc across the case
126 May do more allocation than reqd. This sometimes bites us
127 badly. For example, nfib (ha!) allocates about 30\% more space if the
128 worst-casing is done, because many many calls to nfib are leaf calls
129 which don't need to allocate anything.
131 This never hurts us if there is only one alternative.
135 *** NOT YET DONE *** The difficulty is that \tr{!B!}, \tr{!C!} need
136 to take account of what is live, and that includes all live volatile
137 variables, even if they also have stable analogues. Furthermore, the
138 stack pointers must be lined up properly so that GC sees tidy stacks.
139 If these things are done, then the heap checks can be done at \tr{!B!} and
140 \tr{!C!} without a full save-volatile-vars sequence.
151 Several special cases for primitive operations.
153 ******* TO DO TO DO: fix what follows
157 case (op x1 ... xn) of
160 where the type of the case scrutinee is a multi-constuctor algebraic type.
161 Then we simply compile code for
169 case (op x1 ... xn) of
173 where the type of the case scrutinee is a multi-constuctor algebraic type.
174 we just bomb out at the moment. It never happens in practice.
176 **** END OF TO DO TO DO
179 cgCase scrut@(StgPrim op args _) live_in_whole_case live_in_alts uniq
180 (StgAlgAlts _ alts (StgBindDefault id _ deflt_rhs))
181 = if not (null alts) then
182 panic "cgCase: case on PrimOp with default *and* alts\n"
183 -- For now, die if alts are non-empty
185 cgExpr (StgLet (StgNonRec id scrut_rhs) deflt_rhs)
187 scrut_rhs = StgRhsClosure useCurrentCostCentre stgArgOcc{-safe-} scrut_free_vars
189 scrut_free_vars = [ fv | StgVarArg fv <- args, not (toplevelishId fv) ]
195 cgCase (StgPrim op args _) live_in_whole_case live_in_alts uniq alts
196 | not (primOpCanTriggerGC op)
198 -- Get amodes for the arguments and results
199 getPrimOpArgAmodes op args `thenFC` \ arg_amodes ->
201 result_amodes = getPrimAppResultAmodes uniq alts
202 liveness_mask = panic "cgCase: liveness of non-GC-ing primop touched\n"
204 -- Perform the operation
205 getVolatileRegs live_in_alts `thenFC` \ vol_regs ->
207 -- seq cannot happen here => no additional B Stack alloc
209 absC (COpStmt result_amodes op
210 arg_amodes -- note: no liveness arg
211 liveness_mask vol_regs) `thenC`
213 -- Scrutinise the result
214 cgInlineAlts NoGC uniq alts
216 | otherwise -- *Can* trigger GC
217 = getPrimOpArgAmodes op args `thenFC` \ arg_amodes ->
219 -- Get amodes for the arguments and results, and assign to regs
220 -- (Can-trigger-gc primops guarantee to have their (nonRobust)
223 op_result_regs = assignPrimOpResultRegs op
225 op_result_amodes = map CReg op_result_regs
227 (op_arg_amodes, liveness_mask, arg_assts)
228 = makePrimOpArgsRobust op arg_amodes
230 liveness_arg = mkIntCLit liveness_mask
232 -- Tidy up in case GC happens...
234 -- Nota Bene the use of live_in_whole_case in nukeDeadBindings.
235 -- Reason: the arg_assts computed above may refer to some stack slots
236 -- which are not live in the alts. So we mustn't use those slots
237 -- to save volatile vars in!
238 nukeDeadBindings live_in_whole_case `thenC`
239 saveVolatileVars live_in_alts `thenFC` \ volatile_var_save_assts ->
241 -- Allocate stack words for the prim-op itself,
242 -- these are guaranteed to be ON TOP OF the stack.
243 -- Currently this is used *only* by the seq# primitive op.
245 (a_req,b_req) = case (primOpStackRequired op) of
246 NoStackRequired -> (0, 0)
247 FixedStackRequired a b -> (a, b)
248 VariableStackRequired -> (0, 0) -- i.e. don't care
250 allocAStackTop a_req `thenFC` \ a_slot ->
251 allocBStackTop b_req `thenFC` \ b_slot ->
253 getEndOfBlockInfo `thenFC` \ eob_info@(EndOfBlockInfo args_spa args_spb sequel) ->
254 -- a_req and b_req allocate stack space that is taken care of by the
255 -- macros generated for the primops; thus, we there is no need to adjust
256 -- this part of the stacks later on (=> +a_req in EndOfBlockInfo)
257 -- currently all this is only used for SeqOp
258 forkEval (if True {- a_req==0 && b_req==0 -}
260 else (EndOfBlockInfo (args_spa+a_req)
261 (args_spb+b_req) sequel)) nopC
263 getAbsC (cgInlineAlts GCMayHappen uniq alts) `thenFC` \ abs_c ->
264 absC (CRetUnVector vtbl_label (CLabelledCode return_label abs_c))
266 returnFC (CaseAlts (CUnVecLbl return_label vtbl_label)
267 Nothing{-no semi-tagging-}))
268 `thenFC` \ new_eob_info ->
270 -- Record the continuation info
271 setEndOfBlockInfo new_eob_info (
273 -- Now "return" to the inline alternatives; this will get
274 -- compiled to a fall-through.
276 simultaneous_assts = arg_assts `mkAbsCStmts` volatile_var_save_assts
278 -- do_op_and_continue will be passed an amode for the continuation
279 do_op_and_continue sequel
280 = absC (COpStmt op_result_amodes
282 (pin_liveness op liveness_arg op_arg_amodes)
287 sequelToAmode sequel `thenFC` \ dest_amode ->
288 absC (CReturn dest_amode DirectReturn)
290 -- Note: we CJump even for algebraic data types,
291 -- because cgInlineAlts always generates code, never a
294 performReturn simultaneous_assts do_op_and_continue live_in_alts
297 -- for all PrimOps except ccalls, we pin the liveness info
298 -- on as the first "argument"
299 -- ToDo: un-duplicate?
301 pin_liveness (CCallOp _ _ _ _ _) _ args = args
302 pin_liveness other_op liveness_arg args
305 vtbl_label = mkVecTblLabel uniq
306 return_label = mkReturnPtLabel uniq
310 Another special case: scrutinising a primitive-typed variable. No
311 evaluation required. We don't save volatile variables, nor do we do a
312 heap-check in the alternatives. Instead, the heap usage of the
313 alternatives is worst-cased and passed upstream. This can result in
314 allocating more heap than strictly necessary, but it will sometimes
315 eliminate a heap check altogether.
318 cgCase (StgApp v [] _) live_in_whole_case live_in_alts uniq (StgPrimAlts ty alts deflt)
319 = getArgAmode v `thenFC` \ amode ->
320 cgPrimAltsGivenScrutinee NoGC amode alts deflt
323 Special case: scrutinising a non-primitive variable.
324 This can be done a little better than the general case, because
325 we can reuse/trim the stack slot holding the variable (if it is in one).
328 cgCase (StgApp (StgVarArg fun) args _ {-lvs must be same as live_in_alts-})
329 live_in_whole_case live_in_alts uniq alts@(StgAlgAlts _ _ _)
331 getCAddrModeAndInfo fun `thenFC` \ (fun_amode, lf_info) ->
332 getArgAmodes args `thenFC` \ arg_amodes ->
334 -- Squish the environment
335 nukeDeadBindings live_in_alts `thenC`
336 saveVolatileVarsAndRegs live_in_alts
337 `thenFC` \ (save_assts, alts_eob_info, maybe_cc_slot) ->
339 forkEval alts_eob_info
340 nopC (cgEvalAlts maybe_cc_slot uniq alts) `thenFC` \ scrut_eob_info ->
341 setEndOfBlockInfo scrut_eob_info (
342 tailCallBusiness fun fun_amode lf_info arg_amodes live_in_alts save_assts
347 Finally, here is the general case.
350 cgCase expr live_in_whole_case live_in_alts uniq alts
351 = -- Figure out what volatile variables to save
352 nukeDeadBindings live_in_whole_case `thenC`
353 saveVolatileVarsAndRegs live_in_alts
354 `thenFC` \ (save_assts, alts_eob_info, maybe_cc_slot) ->
356 -- Save those variables right now!
357 absC save_assts `thenC`
359 forkEval alts_eob_info
360 (nukeDeadBindings live_in_alts)
361 (cgEvalAlts maybe_cc_slot uniq alts) `thenFC` \ scrut_eob_info ->
363 setEndOfBlockInfo scrut_eob_info (cgExpr expr)
366 %************************************************************************
368 \subsection[CgCase-primops]{Primitive applications}
370 %************************************************************************
372 Get result amodes for a primitive operation, in the case wher GC can't happen.
373 The amodes are returned in canonical order, ready for the prim-op!
375 Alg case: temporaries named as in the alternatives,
376 plus (CTemp u) for the tag (if needed)
379 This is all disgusting, because these amodes must be consistent with those
380 invented by CgAlgAlts.
383 getPrimAppResultAmodes
390 -- If there's an StgBindDefault which does use the bound
391 -- variable, then we can only handle it if the type involved is
392 -- an enumeration type. That's important in the case
398 -- The only reason for the restriction to *enumeration* types is our
399 -- inability to invent suitable temporaries to hold the results;
400 -- Elaborating the CTemp addr mode to have a second uniq field
401 -- (which would simply count from 1) would solve the problem.
402 -- Anyway, cgInlineAlts is now capable of handling all cases;
403 -- it's only this function which is being wimpish.
405 getPrimAppResultAmodes uniq (StgAlgAlts ty alts (StgBindDefault _ True {- used -} _))
406 | isEnumerationTyCon spec_tycon = [tag_amode]
407 | otherwise = panic "getPrimAppResultAmodes: non-enumeration algebraic alternatives with default"
409 -- A temporary variable to hold the tag; this is unaffected by GC because
410 -- the heap-checks in the branches occur after the switch
411 tag_amode = CTemp uniq IntRep
412 (spec_tycon, _, _) = getAppSpecDataTyConExpandingDicts ty
414 getPrimAppResultAmodes uniq (StgAlgAlts ty alts other_default)
415 -- Default is either StgNoDefault or StgBindDefault with unused binder
417 [_] -> arg_amodes -- No need for a tag
418 other -> tag_amode : arg_amodes
420 -- A temporary variable to hold the tag; this is unaffected by GC because
421 -- the heap-checks in the branches occur after the switch
422 tag_amode = CTemp uniq IntRep
424 -- Sort alternatives into canonical order; there must be a complete
425 -- set because there's no default case.
426 sorted_alts = sortLt lt alts
427 (con1,_,_,_) `lt` (con2,_,_,_) = dataConTag con1 < dataConTag con2
429 arg_amodes :: [CAddrMode]
431 -- Turn them into amodes
432 arg_amodes = concat (map mk_amodes sorted_alts)
433 mk_amodes (con, args, use_mask, rhs)
434 = [ CTemp (uniqueOf arg) (idPrimRep arg) | arg <- args ]
437 The situation is simpler for primitive
438 results, because there is only one!
441 getPrimAppResultAmodes uniq (StgPrimAlts ty _ _)
442 = [CTemp uniq (typePrimRep ty)]
446 %************************************************************************
448 \subsection[CgCase-alts]{Alternatives}
450 %************************************************************************
452 @cgEvalAlts@ returns an addressing mode for a continuation for the
453 alternatives of a @case@, used in a context when there
454 is some evaluation to be done.
457 cgEvalAlts :: Maybe VirtualSpBOffset -- Offset of cost-centre to be restored, if any
460 -> FCode Sequel -- Any addr modes inside are guaranteed to be a label
461 -- so that we can duplicate it without risk of
464 cgEvalAlts cc_slot uniq (StgAlgAlts ty alts deflt)
465 = -- Generate the instruction to restore cost centre, if any
466 restoreCurrentCostCentre cc_slot `thenFC` \ cc_restore ->
468 -- Generate sequel info for use downstream
469 -- At the moment, we only do it if the type is vector-returnable.
470 -- Reason: if not, then it costs extra to label the
471 -- alternatives, because we'd get return code like:
473 -- switch TagReg { 0 : JMP(alt_1); 1 : JMP(alt_2) ..etc }
475 -- which is worse than having the alt code in the switch statement
478 (spec_tycon, _, _) = getAppSpecDataTyConExpandingDicts ty
481 = case ctrlReturnConvAlg spec_tycon of
482 VectoredReturn _ -> True
486 = if not use_labelled_alts then
487 Nothing -- no semi-tagging info
489 cgSemiTaggedAlts uniq alts deflt -- Just <something>
491 cgAlgAlts GCMayHappen uniq cc_restore use_labelled_alts ty alts deflt True
492 `thenFC` \ (tagged_alt_absCs, deflt_absC) ->
494 mkReturnVector uniq ty tagged_alt_absCs deflt_absC `thenFC` \ return_vec ->
496 returnFC (CaseAlts return_vec semi_tagged_stuff)
498 cgEvalAlts cc_slot uniq (StgPrimAlts ty alts deflt)
499 = -- Generate the instruction to restore cost centre, if any
500 restoreCurrentCostCentre cc_slot `thenFC` \ cc_restore ->
502 -- Generate the switch
503 getAbsC (cgPrimAlts GCMayHappen uniq ty alts deflt) `thenFC` \ abs_c ->
505 -- Generate the labelled block, starting with restore-cost-centre
506 absC (CRetUnVector vtbl_label
507 (CLabelledCode return_label (cc_restore `mkAbsCStmts` abs_c)))
509 -- Return an amode for the block
510 returnFC (CaseAlts (CUnVecLbl return_label vtbl_label) Nothing{-no semi-tagging-})
512 vtbl_label = mkVecTblLabel uniq
513 return_label = mkReturnPtLabel uniq
518 cgInlineAlts :: GCFlag -> Unique
523 HWL comment on {\em GrAnSim\/} (adding GRAN_YIELDs for context switch): If
524 we do an inlining of the case no separate functions for returning are
525 created, so we don't have to generate a GRAN_YIELD in that case. This info
526 must be propagated to cgAlgAltRhs (where the GRAN_YIELD macro might be
527 emitted). Hence, the new Bool arg to cgAlgAltRhs.
529 First case: algebraic case, exactly one alternative, no default.
530 In this case the primitive op will not have set a temporary to the
531 tag, so we shouldn't generate a switch statment. Instead we just
535 cgInlineAlts gc_flag uniq (StgAlgAlts ty [alt@(con,args,use_mask,rhs)] StgNoDefault)
536 = cgAlgAltRhs gc_flag con args use_mask rhs False{-no yield macro if alt gets inlined-}
539 Second case: algebraic case, several alternatives.
540 Tag is held in a temporary.
543 cgInlineAlts gc_flag uniq (StgAlgAlts ty alts deflt)
544 = cgAlgAlts gc_flag uniq AbsCNop{-restore_cc-} False{-no semi-tagging-}
546 False{-don't emit yield-} `thenFC` \ (tagged_alts, deflt_c) ->
549 absC (mkAlgAltsCSwitch tag_amode tagged_alts deflt_c)
551 -- A temporary variable to hold the tag; this is unaffected by GC because
552 -- the heap-checks in the branches occur after the switch
553 tag_amode = CTemp uniq IntRep
556 Third (real) case: primitive result type.
559 cgInlineAlts gc_flag uniq (StgPrimAlts ty alts deflt)
560 = cgPrimAlts gc_flag uniq ty alts deflt
564 %************************************************************************
566 \subsection[CgCase-alg-alts]{Algebraic alternatives}
568 %************************************************************************
570 In @cgAlgAlts@, none of the binders in the alternatives are
571 assumed to be yet bound.
573 HWL comment on {\em GrAnSim\/} (adding GRAN_YIELDs for context switch): The
574 last arg of cgAlgAlts indicates if we want a context switch at the
575 beginning of each alternative. Normally we want that. The only exception
576 are inlined alternatives.
581 -> AbstractC -- Restore-cost-centre instruction
582 -> Bool -- True <=> branches must be labelled
583 -> Type -- From the case statement
584 -> [(Id, [Id], [Bool], StgExpr)] -- The alternatives
585 -> StgCaseDefault -- The default
586 -> Bool -- Context switch at alts?
587 -> FCode ([(ConTag, AbstractC)], -- The branches
588 AbstractC -- The default case
592 The case with a default which has a binder is different. We need to
593 pick all the constructors which aren't handled explicitly by an
594 alternative, and which return their results in registers, allocate
595 them explicitly in the heap, and jump to a join point for the default
598 OLD: All of this only works if a heap-check is required anyway, because
599 otherwise it isn't safe to allocate.
601 NEW (July 94): now false! It should work regardless of gc_flag,
602 because of the extra_branches argument now added to forkAlts.
604 We put a heap-check at the join point, for the benefit of constructors
605 which don't need to do allocation. This means that ones which do need
606 to allocate may end up doing two heap-checks; but that's just too bad.
607 (We'd need two join labels otherwise. ToDo.)
609 It's all pretty turgid anyway.
612 cgAlgAlts gc_flag uniq restore_cc semi_tagging
613 ty alts deflt@(StgBindDefault binder True{-used-} _)
614 emit_yield{-should a yield macro be emitted?-}
616 extra_branches :: [FCode (ConTag, AbstractC)]
617 extra_branches = catMaybes (map mk_extra_branch default_cons)
619 must_label_default = semi_tagging || not (null extra_branches)
621 forkAlts (map (cgAlgAlt gc_flag uniq restore_cc semi_tagging emit_yield) alts)
623 (cgAlgDefault gc_flag uniq restore_cc must_label_default deflt emit_yield)
626 default_join_lbl = mkDefaultLabel uniq
627 jump_instruction = CJump (CLbl default_join_lbl CodePtrRep)
629 (spec_tycon, _, spec_cons) = getAppSpecDataTyConExpandingDicts ty
631 alt_cons = [ con | (con,_,_,_) <- alts ]
633 default_cons = [ spec_con | spec_con <- spec_cons, -- In this type
634 spec_con `not_elem` alt_cons ] -- Not handled explicitly
636 not_elem = isn'tIn "cgAlgAlts"
638 -- (mk_extra_branch con) returns the a maybe for the extra branch for con.
639 -- The "maybe" is because con may return in heap, in which case there is
640 -- nothing to do. Otherwise, we have a special case for a nullary constructor,
641 -- but in the general case we do an allocation and heap-check.
643 mk_extra_branch :: DataCon -> (Maybe (FCode (ConTag, AbstractC)))
646 = ASSERT(isDataCon con)
647 case dataReturnConvAlg con of
648 ReturnInHeap -> Nothing
649 ReturnInRegs rs -> Just (getAbsC (alloc_code rs) `thenFC` \ abs_c ->
650 returnFC (tag, abs_c)
653 lf_info = mkConLFInfo con
656 -- alloc_code generates code to allocate constructor con, whose args are
657 -- in the arguments to alloc_code, assigning the result to Node.
658 alloc_code :: [MagicId] -> Code
661 = possibleHeapCheck gc_flag regs False (
662 buildDynCon binder useCurrentCostCentre con
663 (map CReg regs) (all zero_size regs)
665 idInfoToAmode PtrRep idinfo `thenFC` \ amode ->
667 absC (CAssign (CReg node) amode) `thenC`
668 absC jump_instruction
671 zero_size reg = getPrimRepSize (magicIdPrimRep reg) == 0
674 Now comes the general case
677 cgAlgAlts gc_flag uniq restore_cc must_label_branches ty alts deflt
678 {- The deflt is either StgNoDefault or a BindDefault which doesn't use the binder -}
679 emit_yield{-should a yield macro be emitted?-}
681 = forkAlts (map (cgAlgAlt gc_flag uniq restore_cc must_label_branches emit_yield) alts)
682 [{- No "extra branches" -}]
683 (cgAlgDefault gc_flag uniq restore_cc must_label_branches deflt emit_yield)
687 cgAlgDefault :: GCFlag
688 -> Unique -> AbstractC -> Bool -- turgid state...
689 -> StgCaseDefault -- input
691 -> FCode AbstractC -- output
693 cgAlgDefault gc_flag uniq restore_cc must_label_branch
697 cgAlgDefault gc_flag uniq restore_cc must_label_branch
698 (StgBindDefault _ False{-binder not used-} rhs)
699 emit_yield{-should a yield macro be emitted?-}
701 = getAbsC (absC restore_cc `thenC`
703 emit_gran_macros = opt_GranMacros
705 (if emit_gran_macros && emit_yield
707 else absC AbsCNop) `thenC`
708 -- liveness same as in possibleHeapCheck below
709 possibleHeapCheck gc_flag [] False (cgExpr rhs)) `thenFC` \ abs_c ->
711 final_abs_c | must_label_branch = CJump (CLabelledCode lbl abs_c)
716 lbl = mkDefaultLabel uniq
719 cgAlgDefault gc_flag uniq restore_cc must_label_branch
720 (StgBindDefault binder True{-binder used-} rhs)
721 emit_yield{-should a yield macro be emitted?-}
723 = -- We have arranged that Node points to the thing, even
724 -- even if we return in registers
725 bindNewToReg binder node mkLFArgument `thenC`
726 getAbsC (absC restore_cc `thenC`
728 emit_gran_macros = opt_GranMacros
730 (if emit_gran_macros && emit_yield
731 then yield [node] False
732 else absC AbsCNop) `thenC`
733 -- liveness same as in possibleHeapCheck below
734 possibleHeapCheck gc_flag [node] False (cgExpr rhs)
735 -- Node is live, but doesn't need to point at the thing itself;
736 -- it's ok for Node to point to an indirection or FETCH_ME
737 -- Hence no need to re-enter Node.
738 ) `thenFC` \ abs_c ->
741 final_abs_c | must_label_branch = CJump (CLabelledCode lbl abs_c)
746 lbl = mkDefaultLabel uniq
748 -- HWL comment on GrAnSim: GRAN_YIELDs needed; emitted in cgAlgAltRhs
751 -> Unique -> AbstractC -> Bool -- turgid state
752 -> Bool -- Context switch at alts?
753 -> (Id, [Id], [Bool], StgExpr)
754 -> FCode (ConTag, AbstractC)
756 cgAlgAlt gc_flag uniq restore_cc must_label_branch
757 emit_yield{-should a yield macro be emitted?-}
758 (con, args, use_mask, rhs)
759 = getAbsC (absC restore_cc `thenC`
760 cgAlgAltRhs gc_flag con args use_mask rhs
762 ) `thenFC` \ abs_c ->
764 final_abs_c | must_label_branch = CJump (CLabelledCode lbl abs_c)
767 returnFC (tag, final_abs_c)
770 lbl = mkAltLabel uniq tag
772 cgAlgAltRhs :: GCFlag
777 -> Bool -- context switch?
779 cgAlgAltRhs gc_flag con args use_mask rhs emit_yield
781 (live_regs, node_reqd)
782 = case (dataReturnConvAlg con) of
783 ReturnInHeap -> ([], True)
784 ReturnInRegs regs -> ([reg | (reg,True) <- zipEqual "cgAlgAltRhs" regs use_mask], False)
785 -- Pick the live registers using the use_mask
786 -- Doing so is IMPORTANT, because with semi-tagging
787 -- enabled only the live registers will have valid
791 emit_gran_macros = opt_GranMacros
793 (if emit_gran_macros && emit_yield
794 then yield live_regs node_reqd
795 else absC AbsCNop) `thenC`
796 -- liveness same as in possibleHeapCheck below
797 possibleHeapCheck gc_flag live_regs node_reqd (
799 NoGC -> mapFCs bindNewToTemp args `thenFC` \ _ ->
801 GCMayHappen -> bindConArgs con args
807 %************************************************************************
809 \subsection[CgCase-semi-tagged-alts]{The code to deal with sem-tagging}
811 %************************************************************************
813 Turgid-but-non-monadic code to conjure up the required info from
814 algebraic case alternatives for semi-tagging.
817 cgSemiTaggedAlts :: Unique
818 -> [(Id, [Id], [Bool], StgExpr)]
819 -> GenStgCaseDefault Id Id
822 cgSemiTaggedAlts uniq alts deflt
823 = Just (map st_alt alts, st_deflt deflt)
825 st_deflt StgNoDefault = Nothing
827 st_deflt (StgBindDefault binder binder_used _)
828 = Just (if binder_used then Just binder else Nothing,
829 (CCallProfCtrMacro SLIT("RET_SEMI_BY_DEFAULT") [], -- ToDo: monadise?
833 st_alt (con, args, use_mask, _)
834 = case (dataReturnConvAlg con) of
837 -- Ha! Nothing to do; Node already points to the thing
839 (CCallProfCtrMacro SLIT("RET_SEMI_IN_HEAP") -- ToDo: monadise?
840 [mkIntCLit (length args)], -- how big the thing in the heap is
845 -- We have to load the live registers from the constructor
846 -- pointed to by Node.
848 (_, regs_w_offsets) = layOutDynCon con magicIdPrimRep regs
850 used_regs = selectByMask use_mask regs
852 used_regs_w_offsets = [ ro | ro@(reg,offset) <- regs_w_offsets,
853 reg `is_elem` used_regs]
855 is_elem = isIn "cgSemiTaggedAlts"
859 CCallProfCtrMacro SLIT("RET_SEMI_IN_REGS") -- ToDo: macroise?
860 [mkIntCLit (length regs_w_offsets),
861 mkIntCLit (length used_regs_w_offsets)],
862 CSimultaneous (mkAbstractCs (map move_to_reg used_regs_w_offsets))],
865 con_tag = dataConTag con
866 join_label = mkAltLabel uniq con_tag
868 move_to_reg :: (MagicId, VirtualHeapOffset {-from Node-}) -> AbstractC
869 move_to_reg (reg, offset)
870 = CAssign (CReg reg) (CVal (NodeRel offset) (magicIdPrimRep reg))
873 %************************************************************************
875 \subsection[CgCase-prim-alts]{Primitive alternatives}
877 %************************************************************************
879 @cgPrimAlts@ generates a suitable @CSwitch@ for dealing with the
880 alternatives of a primitive @case@, given an addressing mode for the
881 thing to scrutinise. It also keeps track of the maximum stack depth
882 encountered down any branch.
884 As usual, no binders in the alternatives are yet bound.
890 -> [(Literal, StgExpr)] -- Alternatives
891 -> StgCaseDefault -- Default
894 cgPrimAlts gc_flag uniq ty alts deflt
895 = cgPrimAltsGivenScrutinee gc_flag scrutinee alts deflt
897 -- A temporary variable, or standard register, to hold the result
898 scrutinee = case gc_flag of
899 NoGC -> CTemp uniq kind
900 GCMayHappen -> CReg (dataReturnConvPrim kind)
902 kind = typePrimRep ty
905 cgPrimAltsGivenScrutinee gc_flag scrutinee alts deflt
906 = forkAlts (map (cgPrimAlt gc_flag) alts)
907 [{- No "extra branches" -}]
908 (cgPrimDefault gc_flag scrutinee deflt) `thenFC` \ (alt_absCs, deflt_absC) ->
909 absC (CSwitch scrutinee alt_absCs deflt_absC)
910 -- CSwitch does sensible things with one or zero alternatives
914 -> (Literal, StgExpr) -- The alternative
915 -> FCode (Literal, AbstractC) -- Its compiled form
917 cgPrimAlt gc_flag (lit, rhs)
918 = getAbsC rhs_code `thenFC` \ absC ->
921 rhs_code = possibleHeapCheck gc_flag [] False (cgExpr rhs )
923 cgPrimDefault :: GCFlag
924 -> CAddrMode -- Scrutinee
928 cgPrimDefault gc_flag scrutinee StgNoDefault
929 = panic "cgPrimDefault: No default in prim case"
931 cgPrimDefault gc_flag scrutinee (StgBindDefault _ False{-binder not used-} rhs)
932 = getAbsC (possibleHeapCheck gc_flag [] False (cgExpr rhs ))
934 cgPrimDefault gc_flag scrutinee (StgBindDefault binder True{-used-} rhs)
935 = getAbsC (possibleHeapCheck gc_flag regs False rhs_code)
937 regs = if isFollowableRep (getAmodeRep scrutinee) then
940 rhs_code = bindNewPrimToAmode binder scrutinee `thenC`
945 %************************************************************************
947 \subsection[CgCase-tidy]{Code for tidying up prior to an eval}
949 %************************************************************************
952 saveVolatileVarsAndRegs
953 :: StgLiveVars -- Vars which should be made safe
954 -> FCode (AbstractC, -- Assignments to do the saves
955 EndOfBlockInfo, -- New sequel, recording where the return
957 Maybe VirtualSpBOffset) -- Slot for current cost centre
960 saveVolatileVarsAndRegs vars
961 = saveVolatileVars vars `thenFC` \ var_saves ->
962 saveCurrentCostCentre `thenFC` \ (maybe_cc_slot, cc_save) ->
963 saveReturnAddress `thenFC` \ (new_eob_info, ret_save) ->
964 returnFC (mkAbstractCs [var_saves, cc_save, ret_save],
969 saveVolatileVars :: StgLiveVars -- Vars which should be made safe
970 -> FCode AbstractC -- Assignments to to the saves
972 saveVolatileVars vars
973 = save_em (idSetToList vars)
975 save_em [] = returnFC AbsCNop
978 = getCAddrModeIfVolatile var `thenFC` \ v ->
980 Nothing -> save_em vars -- Non-volatile, so carry on
983 Just vol_amode -> -- Aha! It's volatile
984 save_var var vol_amode `thenFC` \ abs_c ->
985 save_em vars `thenFC` \ abs_cs ->
986 returnFC (abs_c `mkAbsCStmts` abs_cs)
988 save_var var vol_amode
989 | isFollowableRep kind
990 = allocAStack `thenFC` \ a_slot ->
991 rebindToAStack var a_slot `thenC`
992 getSpARelOffset a_slot `thenFC` \ spa_rel ->
993 returnFC (CAssign (CVal spa_rel kind) vol_amode)
995 = allocBStack (getPrimRepSize kind) `thenFC` \ b_slot ->
996 rebindToBStack var b_slot `thenC`
997 getSpBRelOffset b_slot `thenFC` \ spb_rel ->
998 returnFC (CAssign (CVal spb_rel kind) vol_amode)
1000 kind = getAmodeRep vol_amode
1002 saveReturnAddress :: FCode (EndOfBlockInfo, AbstractC)
1004 = getEndOfBlockInfo `thenFC` \ eob_info@(EndOfBlockInfo vA vB sequel) ->
1006 -- See if it is volatile
1008 InRetReg -> -- Yes, it's volatile
1009 allocBStack retPrimRepSize `thenFC` \ b_slot ->
1010 getSpBRelOffset b_slot `thenFC` \ spb_rel ->
1012 returnFC (EndOfBlockInfo vA vB (OnStack b_slot),
1013 CAssign (CVal spb_rel RetRep) (CReg RetReg))
1015 UpdateCode _ -> -- It's non-volatile all right, but we still need
1016 -- to allocate a B-stack slot for it, *solely* to make
1017 -- sure that update frames for different values do not
1018 -- appear adjacent on the B stack. This makes sure
1019 -- that B-stack squeezing works ok.
1021 allocBStack retPrimRepSize `thenFC` \ b_slot ->
1022 returnFC (eob_info, AbsCNop)
1024 other -> -- No, it's non-volatile, so do nothing
1025 returnFC (eob_info, AbsCNop)
1028 Note about B-stack squeezing. Consider the following:`
1030 y = [...] \u [] -> ...
1031 x = [y] \u [] -> case y of (a,b) -> a
1033 The code for x will push an update frame, and then enter y. The code
1034 for y will push another update frame. If the B-stack-squeezer then
1035 wakes up, it will see two update frames right on top of each other,
1036 and will combine them. This is WRONG, of course, because x's value is
1037 not the same as y's.
1039 The fix implemented above makes sure that we allocate an (unused)
1040 B-stack slot before entering y. You can think of this as holding the
1041 saved value of RetAddr, which (after pushing x's update frame will be
1042 some update code ptr). The compiler is clever enough to load the
1043 static update code ptr into RetAddr before entering ~a~, but the slot
1044 is still there to separate the update frames.
1046 When we save the current cost centre (which is done for lexical
1047 scoping), we allocate a free B-stack location, and return (a)~the
1048 virtual offset of the location, to pass on to the alternatives, and
1049 (b)~the assignment to do the save (just as for @saveVolatileVars@).
1052 saveCurrentCostCentre ::
1053 FCode (Maybe VirtualSpBOffset, -- Where we decide to store it
1054 -- Nothing if not lexical CCs
1055 AbstractC) -- Assignment to save it
1056 -- AbsCNop if not lexical CCs
1058 saveCurrentCostCentre
1060 doing_profiling = opt_SccProfilingOn
1062 if not doing_profiling then
1063 returnFC (Nothing, AbsCNop)
1065 allocBStack (getPrimRepSize CostCentreRep) `thenFC` \ b_slot ->
1066 getSpBRelOffset b_slot `thenFC` \ spb_rel ->
1067 returnFC (Just b_slot,
1068 CAssign (CVal spb_rel CostCentreRep) (CReg CurCostCentre))
1070 restoreCurrentCostCentre :: Maybe VirtualSpBOffset -> FCode AbstractC
1072 restoreCurrentCostCentre Nothing
1074 restoreCurrentCostCentre (Just b_slot)
1075 = getSpBRelOffset b_slot `thenFC` \ spb_rel ->
1076 freeBStkSlot b_slot `thenC`
1077 returnFC (CCallProfCCMacro SLIT("RESTORE_CCC") [CVal spb_rel CostCentreRep])
1078 -- we use the RESTORE_CCC macro, rather than just
1079 -- assigning into CurCostCentre, in case RESTORE_CCC
1080 -- has some sanity-checking in it.
1084 %************************************************************************
1086 \subsection[CgCase-return-vec]{Building a return vector}
1088 %************************************************************************
1090 Build a return vector, and return a suitable label addressing
1094 mkReturnVector :: Unique
1096 -> [(ConTag, AbstractC)] -- Branch codes
1097 -> AbstractC -- Default case
1100 mkReturnVector uniq ty tagged_alt_absCs deflt_absC
1102 (return_vec_amode, vtbl_body) = case (ctrlReturnConvAlg spec_tycon) of {
1104 UnvectoredReturn _ ->
1105 (CUnVecLbl ret_label vtbl_label,
1106 absC (CRetUnVector vtbl_label
1107 (CLabelledCode ret_label
1108 (mkAlgAltsCSwitch (CReg TagReg)
1111 VectoredReturn table_size ->
1112 (CLbl vtbl_label DataPtrRep,
1113 absC (CRetVector vtbl_label
1114 -- must restore cc before each alt, if required
1115 (map mk_vector_entry [fIRST_TAG .. (table_size+fIRST_TAG-1)])
1118 -- Leave nops and comments in for now; they are eliminated
1119 -- lazily as it's printed.
1120 -- (case (nonemptyAbsC deflt_absC) of
1121 -- Nothing -> AbsCNop
1126 returnFC return_vec_amode
1130 (spec_tycon,_,_) = case (maybeAppSpecDataTyConExpandingDicts ty) of -- *must* be a real "data" type constructor
1132 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)
1134 vtbl_label = mkVecTblLabel uniq
1135 ret_label = mkReturnPtLabel uniq
1137 mk_vector_entry :: ConTag -> Maybe CAddrMode
1139 = case [ absC | (t, absC) <- tagged_alt_absCs, t == tag ] of
1141 [absC] -> Just (CCode absC)
1142 _ -> panic "mkReturnVector: too many"
1145 %************************************************************************
1147 \subsection[CgCase-utils]{Utilities for handling case expressions}
1149 %************************************************************************
1151 @possibleHeapCheck@ tests a flag passed in to decide whether to
1152 do a heap check or not.
1155 possibleHeapCheck :: GCFlag -> [MagicId] -> Bool -> Code -> Code
1157 possibleHeapCheck GCMayHappen regs node_reqd code = heapCheck regs node_reqd code
1158 possibleHeapCheck NoGC _ _ code = code
1161 Select a restricted set of registers based on a usage mask.
1164 selectByMask [] [] = []
1165 selectByMask (True:ms) (x:xs) = x : selectByMask ms xs
1166 selectByMask (False:ms) (x:xs) = selectByMask ms xs