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 #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <= 201
17 IMPORT_DELOOPER(CgLoop2) ( cgExpr, getPrimOpArgAmodes )
19 import {-# SOURCE #-} CgExpr
26 import AbsCUtils ( mkAbstractCs, mkAbsCStmts, mkAlgAltsCSwitch,
27 magicIdPrimRep, getAmodeRep
29 import CgBindery ( getVolatileRegs, getArgAmode, getArgAmodes,
30 bindNewToReg, bindNewToTemp,
32 rebindToAStack, rebindToBStack,
33 getCAddrModeAndInfo, getCAddrModeIfVolatile,
36 import CgCon ( buildDynCon, bindConArgs )
37 import CgHeapery ( heapCheck, yield )
38 import CgRetConv ( dataReturnConvAlg, dataReturnConvPrim,
40 DataReturnConvention(..), CtrlReturnConvention(..),
41 assignPrimOpResultRegs,
44 import CgStackery ( allocAStack, allocBStack, allocAStackTop, allocBStackTop )
45 import CgTailCall ( tailCallBusiness, performReturn )
46 import CgUsages ( getSpARelOffset, getSpBRelOffset, freeBStkSlot )
47 import CLabel ( mkVecTblLabel, mkReturnPtLabel, mkDefaultLabel,
50 import ClosureInfo ( mkConLFInfo, mkLFArgument, layOutDynCon )
51 import CmdLineOpts ( opt_SccProfilingOn, opt_GranMacros )
52 import CostCentre ( useCurrentCostCentre, CostCentre )
53 import HeapOffs ( SYN_IE(VirtualSpBOffset), SYN_IE(VirtualHeapOffset) )
54 import Id ( idPrimRep, toplevelishId,
55 dataConTag, fIRST_TAG, SYN_IE(ConTag),
56 isDataCon, SYN_IE(DataCon),
57 idSetToList, GenId{-instance Uniquable,Eq-}, SYN_IE(Id)
59 import Literal ( Literal )
60 import Maybes ( catMaybes )
61 import Outputable ( Outputable(..), PprStyle(..) )
62 import PprType ( GenType{-instance Outputable-} )
64 import PrimOp ( primOpCanTriggerGC, PrimOp(..),
65 primOpStackRequired, StackRequirement(..)
67 import PrimRep ( getPrimRepSize, isFollowableRep, retPrimRepSize,
70 import TyCon ( isEnumerationTyCon )
71 import Type ( typePrimRep,
72 getAppSpecDataTyConExpandingDicts,
73 maybeAppSpecDataTyConExpandingDicts,
76 import Unique ( Unique )
77 import UniqFM ( Uniquable(..) )
78 import Util ( sortLt, isIn, isn'tIn, zipEqual,
79 pprError, panic, assertPanic
86 = GCMayHappen -- The scrutinee may involve GC, so everything must be
87 -- tidy before the code for the scrutinee.
89 | NoGC -- The scrutinee is a primitive value, or a call to a
90 -- primitive op which does no GC. Hence the case can
91 -- be done inline, without tidying up first.
94 It is quite interesting to decide whether to put a heap-check
95 at the start of each alternative. Of course we certainly have
96 to do so if the case forces an evaluation, or if there is a primitive
97 op which can trigger GC.
99 A more interesting situation is this:
106 default -> !C!; ...C...
109 where \tr{!x!} indicates a possible heap-check point. The heap checks
110 in the alternatives {\em can} be omitted, in which case the topmost
111 heapcheck will take their worst case into account.
113 In favour of omitting \tr{!B!}, \tr{!C!}:
117 {\em May} save a heap overflow test,
118 if ...A... allocates anything. The other advantage
119 of this is that we can use relative addressing
120 from a single Hp to get at all the closures so allocated.
122 No need to save volatile vars etc across the case
129 May do more allocation than reqd. This sometimes bites us
130 badly. For example, nfib (ha!) allocates about 30\% more space if the
131 worst-casing is done, because many many calls to nfib are leaf calls
132 which don't need to allocate anything.
134 This never hurts us if there is only one alternative.
138 *** NOT YET DONE *** The difficulty is that \tr{!B!}, \tr{!C!} need
139 to take account of what is live, and that includes all live volatile
140 variables, even if they also have stable analogues. Furthermore, the
141 stack pointers must be lined up properly so that GC sees tidy stacks.
142 If these things are done, then the heap checks can be done at \tr{!B!} and
143 \tr{!C!} without a full save-volatile-vars sequence.
154 Several special cases for primitive operations.
156 ******* TO DO TO DO: fix what follows
160 case (op x1 ... xn) of
163 where the type of the case scrutinee is a multi-constuctor algebraic type.
164 Then we simply compile code for
172 case (op x1 ... xn) of
176 where the type of the case scrutinee is a multi-constuctor algebraic type.
177 we just bomb out at the moment. It never happens in practice.
179 **** END OF TO DO TO DO
182 cgCase scrut@(StgPrim op args _) live_in_whole_case live_in_alts uniq
183 (StgAlgAlts _ alts (StgBindDefault id _ deflt_rhs))
184 = if not (null alts) then
185 panic "cgCase: case on PrimOp with default *and* alts\n"
186 -- For now, die if alts are non-empty
188 cgExpr (StgLet (StgNonRec id scrut_rhs) deflt_rhs)
190 scrut_rhs = StgRhsClosure useCurrentCostCentre stgArgOcc{-safe-} scrut_free_vars
192 scrut_free_vars = [ fv | StgVarArg fv <- args, not (toplevelishId fv) ]
198 cgCase (StgPrim op args _) live_in_whole_case live_in_alts uniq alts
199 | not (primOpCanTriggerGC op)
201 -- Get amodes for the arguments and results
202 getPrimOpArgAmodes op args `thenFC` \ arg_amodes ->
204 result_amodes = getPrimAppResultAmodes uniq alts
205 liveness_mask = panic "cgCase: liveness of non-GC-ing primop touched\n"
207 -- Perform the operation
208 getVolatileRegs live_in_alts `thenFC` \ vol_regs ->
210 -- seq cannot happen here => no additional B Stack alloc
212 absC (COpStmt result_amodes op
213 arg_amodes -- note: no liveness arg
214 liveness_mask vol_regs) `thenC`
216 -- Scrutinise the result
217 cgInlineAlts NoGC uniq alts
219 | otherwise -- *Can* trigger GC
220 = getPrimOpArgAmodes op args `thenFC` \ arg_amodes ->
222 -- Get amodes for the arguments and results, and assign to regs
223 -- (Can-trigger-gc primops guarantee to have their (nonRobust)
226 op_result_regs = assignPrimOpResultRegs op
228 op_result_amodes = map CReg op_result_regs
230 (op_arg_amodes, liveness_mask, arg_assts)
231 = makePrimOpArgsRobust op arg_amodes
233 liveness_arg = mkIntCLit liveness_mask
235 -- Tidy up in case GC happens...
237 -- Nota Bene the use of live_in_whole_case in nukeDeadBindings.
238 -- Reason: the arg_assts computed above may refer to some stack slots
239 -- which are not live in the alts. So we mustn't use those slots
240 -- to save volatile vars in!
241 nukeDeadBindings live_in_whole_case `thenC`
242 saveVolatileVars live_in_alts `thenFC` \ volatile_var_save_assts ->
244 -- Allocate stack words for the prim-op itself,
245 -- these are guaranteed to be ON TOP OF the stack.
246 -- Currently this is used *only* by the seq# primitive op.
248 (a_req,b_req) = case (primOpStackRequired op) of
249 NoStackRequired -> (0, 0)
250 FixedStackRequired a b -> (a, b)
251 VariableStackRequired -> (0, 0) -- i.e. don't care
253 allocAStackTop a_req `thenFC` \ a_slot ->
254 allocBStackTop b_req `thenFC` \ b_slot ->
256 getEndOfBlockInfo `thenFC` \ eob_info@(EndOfBlockInfo args_spa args_spb sequel) ->
257 -- a_req and b_req allocate stack space that is taken care of by the
258 -- macros generated for the primops; thus, we there is no need to adjust
259 -- this part of the stacks later on (=> +a_req in EndOfBlockInfo)
260 -- currently all this is only used for SeqOp
261 forkEval (if True {- a_req==0 && b_req==0 -}
263 else (EndOfBlockInfo (args_spa+a_req)
264 (args_spb+b_req) sequel)) nopC
266 getAbsC (cgInlineAlts GCMayHappen uniq alts) `thenFC` \ abs_c ->
267 absC (CRetUnVector vtbl_label (CLabelledCode return_label abs_c))
269 returnFC (CaseAlts (CUnVecLbl return_label vtbl_label)
270 Nothing{-no semi-tagging-}))
271 `thenFC` \ new_eob_info ->
273 -- Record the continuation info
274 setEndOfBlockInfo new_eob_info (
276 -- Now "return" to the inline alternatives; this will get
277 -- compiled to a fall-through.
279 simultaneous_assts = arg_assts `mkAbsCStmts` volatile_var_save_assts
281 -- do_op_and_continue will be passed an amode for the continuation
282 do_op_and_continue sequel
283 = absC (COpStmt op_result_amodes
285 (pin_liveness op liveness_arg op_arg_amodes)
290 sequelToAmode sequel `thenFC` \ dest_amode ->
291 absC (CReturn dest_amode DirectReturn)
293 -- Note: we CJump even for algebraic data types,
294 -- because cgInlineAlts always generates code, never a
297 performReturn simultaneous_assts do_op_and_continue live_in_alts
300 -- for all PrimOps except ccalls, we pin the liveness info
301 -- on as the first "argument"
302 -- ToDo: un-duplicate?
304 pin_liveness (CCallOp _ _ _ _ _) _ args = args
305 pin_liveness other_op liveness_arg args
308 vtbl_label = mkVecTblLabel uniq
309 return_label = mkReturnPtLabel uniq
313 Another special case: scrutinising a primitive-typed variable. No
314 evaluation required. We don't save volatile variables, nor do we do a
315 heap-check in the alternatives. Instead, the heap usage of the
316 alternatives is worst-cased and passed upstream. This can result in
317 allocating more heap than strictly necessary, but it will sometimes
318 eliminate a heap check altogether.
321 cgCase (StgApp v [] _) live_in_whole_case live_in_alts uniq (StgPrimAlts ty alts deflt)
322 = getArgAmode v `thenFC` \ amode ->
323 cgPrimAltsGivenScrutinee NoGC amode alts deflt
326 Special case: scrutinising a non-primitive variable.
327 This can be done a little better than the general case, because
328 we can reuse/trim the stack slot holding the variable (if it is in one).
331 cgCase (StgApp (StgVarArg fun) args _ {-lvs must be same as live_in_alts-})
332 live_in_whole_case live_in_alts uniq alts@(StgAlgAlts _ _ _)
334 getCAddrModeAndInfo fun `thenFC` \ (fun_amode, lf_info) ->
335 getArgAmodes args `thenFC` \ arg_amodes ->
337 -- Squish the environment
338 nukeDeadBindings live_in_alts `thenC`
339 saveVolatileVarsAndRegs live_in_alts
340 `thenFC` \ (save_assts, alts_eob_info, maybe_cc_slot) ->
342 forkEval alts_eob_info
343 nopC (cgEvalAlts maybe_cc_slot uniq alts) `thenFC` \ scrut_eob_info ->
344 setEndOfBlockInfo scrut_eob_info (
345 tailCallBusiness fun fun_amode lf_info arg_amodes live_in_alts save_assts
350 Finally, here is the general case.
353 cgCase expr live_in_whole_case live_in_alts uniq alts
354 = -- Figure out what volatile variables to save
355 nukeDeadBindings live_in_whole_case `thenC`
356 saveVolatileVarsAndRegs live_in_alts
357 `thenFC` \ (save_assts, alts_eob_info, maybe_cc_slot) ->
359 -- Save those variables right now!
360 absC save_assts `thenC`
362 forkEval alts_eob_info
363 (nukeDeadBindings live_in_alts)
364 (cgEvalAlts maybe_cc_slot uniq alts) `thenFC` \ scrut_eob_info ->
366 setEndOfBlockInfo scrut_eob_info (cgExpr expr)
369 %************************************************************************
371 \subsection[CgCase-primops]{Primitive applications}
373 %************************************************************************
375 Get result amodes for a primitive operation, in the case wher GC can't happen.
376 The amodes are returned in canonical order, ready for the prim-op!
378 Alg case: temporaries named as in the alternatives,
379 plus (CTemp u) for the tag (if needed)
382 This is all disgusting, because these amodes must be consistent with those
383 invented by CgAlgAlts.
386 getPrimAppResultAmodes
393 -- If there's an StgBindDefault which does use the bound
394 -- variable, then we can only handle it if the type involved is
395 -- an enumeration type. That's important in the case
401 -- The only reason for the restriction to *enumeration* types is our
402 -- inability to invent suitable temporaries to hold the results;
403 -- Elaborating the CTemp addr mode to have a second uniq field
404 -- (which would simply count from 1) would solve the problem.
405 -- Anyway, cgInlineAlts is now capable of handling all cases;
406 -- it's only this function which is being wimpish.
408 getPrimAppResultAmodes uniq (StgAlgAlts ty alts (StgBindDefault _ True {- used -} _))
409 | isEnumerationTyCon spec_tycon = [tag_amode]
410 | otherwise = panic "getPrimAppResultAmodes: non-enumeration algebraic alternatives with default"
412 -- A temporary variable to hold the tag; this is unaffected by GC because
413 -- the heap-checks in the branches occur after the switch
414 tag_amode = CTemp uniq IntRep
415 (spec_tycon, _, _) = getAppSpecDataTyConExpandingDicts ty
417 getPrimAppResultAmodes uniq (StgAlgAlts ty alts other_default)
418 -- Default is either StgNoDefault or StgBindDefault with unused binder
420 [_] -> arg_amodes -- No need for a tag
421 other -> tag_amode : arg_amodes
423 -- A temporary variable to hold the tag; this is unaffected by GC because
424 -- the heap-checks in the branches occur after the switch
425 tag_amode = CTemp uniq IntRep
427 -- Sort alternatives into canonical order; there must be a complete
428 -- set because there's no default case.
429 sorted_alts = sortLt lt alts
430 (con1,_,_,_) `lt` (con2,_,_,_) = dataConTag con1 < dataConTag con2
432 arg_amodes :: [CAddrMode]
434 -- Turn them into amodes
435 arg_amodes = concat (map mk_amodes sorted_alts)
436 mk_amodes (con, args, use_mask, rhs)
437 = [ CTemp (uniqueOf arg) (idPrimRep arg) | arg <- args ]
440 The situation is simpler for primitive
441 results, because there is only one!
444 getPrimAppResultAmodes uniq (StgPrimAlts ty _ _)
445 = [CTemp uniq (typePrimRep ty)]
449 %************************************************************************
451 \subsection[CgCase-alts]{Alternatives}
453 %************************************************************************
455 @cgEvalAlts@ returns an addressing mode for a continuation for the
456 alternatives of a @case@, used in a context when there
457 is some evaluation to be done.
460 cgEvalAlts :: Maybe VirtualSpBOffset -- Offset of cost-centre to be restored, if any
463 -> FCode Sequel -- Any addr modes inside are guaranteed to be a label
464 -- so that we can duplicate it without risk of
467 cgEvalAlts cc_slot uniq (StgAlgAlts ty alts deflt)
468 = -- Generate the instruction to restore cost centre, if any
469 restoreCurrentCostCentre cc_slot `thenFC` \ cc_restore ->
471 -- Generate sequel info for use downstream
472 -- At the moment, we only do it if the type is vector-returnable.
473 -- Reason: if not, then it costs extra to label the
474 -- alternatives, because we'd get return code like:
476 -- switch TagReg { 0 : JMP(alt_1); 1 : JMP(alt_2) ..etc }
478 -- which is worse than having the alt code in the switch statement
481 (spec_tycon, _, _) = getAppSpecDataTyConExpandingDicts ty
484 = case ctrlReturnConvAlg spec_tycon of
485 VectoredReturn _ -> True
489 = if not use_labelled_alts then
490 Nothing -- no semi-tagging info
492 cgSemiTaggedAlts uniq alts deflt -- Just <something>
494 cgAlgAlts GCMayHappen uniq cc_restore use_labelled_alts ty alts deflt True
495 `thenFC` \ (tagged_alt_absCs, deflt_absC) ->
497 mkReturnVector uniq ty tagged_alt_absCs deflt_absC `thenFC` \ return_vec ->
499 returnFC (CaseAlts return_vec semi_tagged_stuff)
501 cgEvalAlts cc_slot uniq (StgPrimAlts ty alts deflt)
502 = -- Generate the instruction to restore cost centre, if any
503 restoreCurrentCostCentre cc_slot `thenFC` \ cc_restore ->
505 -- Generate the switch
506 getAbsC (cgPrimAlts GCMayHappen uniq ty alts deflt) `thenFC` \ abs_c ->
508 -- Generate the labelled block, starting with restore-cost-centre
509 absC (CRetUnVector vtbl_label
510 (CLabelledCode return_label (cc_restore `mkAbsCStmts` abs_c)))
512 -- Return an amode for the block
513 returnFC (CaseAlts (CUnVecLbl return_label vtbl_label) Nothing{-no semi-tagging-})
515 vtbl_label = mkVecTblLabel uniq
516 return_label = mkReturnPtLabel uniq
521 cgInlineAlts :: GCFlag -> Unique
526 HWL comment on {\em GrAnSim\/} (adding GRAN_YIELDs for context switch): If
527 we do an inlining of the case no separate functions for returning are
528 created, so we don't have to generate a GRAN_YIELD in that case. This info
529 must be propagated to cgAlgAltRhs (where the GRAN_YIELD macro might be
530 emitted). Hence, the new Bool arg to cgAlgAltRhs.
532 First case: algebraic case, exactly one alternative, no default.
533 In this case the primitive op will not have set a temporary to the
534 tag, so we shouldn't generate a switch statment. Instead we just
538 cgInlineAlts gc_flag uniq (StgAlgAlts ty [alt@(con,args,use_mask,rhs)] StgNoDefault)
539 = cgAlgAltRhs gc_flag con args use_mask rhs False{-no yield macro if alt gets inlined-}
542 Second case: algebraic case, several alternatives.
543 Tag is held in a temporary.
546 cgInlineAlts gc_flag uniq (StgAlgAlts ty alts deflt)
547 = cgAlgAlts gc_flag uniq AbsCNop{-restore_cc-} False{-no semi-tagging-}
549 False{-don't emit yield-} `thenFC` \ (tagged_alts, deflt_c) ->
552 absC (mkAlgAltsCSwitch tag_amode tagged_alts deflt_c)
554 -- A temporary variable to hold the tag; this is unaffected by GC because
555 -- the heap-checks in the branches occur after the switch
556 tag_amode = CTemp uniq IntRep
559 Third (real) case: primitive result type.
562 cgInlineAlts gc_flag uniq (StgPrimAlts ty alts deflt)
563 = cgPrimAlts gc_flag uniq ty alts deflt
567 %************************************************************************
569 \subsection[CgCase-alg-alts]{Algebraic alternatives}
571 %************************************************************************
573 In @cgAlgAlts@, none of the binders in the alternatives are
574 assumed to be yet bound.
576 HWL comment on {\em GrAnSim\/} (adding GRAN_YIELDs for context switch): The
577 last arg of cgAlgAlts indicates if we want a context switch at the
578 beginning of each alternative. Normally we want that. The only exception
579 are inlined alternatives.
584 -> AbstractC -- Restore-cost-centre instruction
585 -> Bool -- True <=> branches must be labelled
586 -> Type -- From the case statement
587 -> [(Id, [Id], [Bool], StgExpr)] -- The alternatives
588 -> StgCaseDefault -- The default
589 -> Bool -- Context switch at alts?
590 -> FCode ([(ConTag, AbstractC)], -- The branches
591 AbstractC -- The default case
595 The case with a default which has a binder is different. We need to
596 pick all the constructors which aren't handled explicitly by an
597 alternative, and which return their results in registers, allocate
598 them explicitly in the heap, and jump to a join point for the default
601 OLD: All of this only works if a heap-check is required anyway, because
602 otherwise it isn't safe to allocate.
604 NEW (July 94): now false! It should work regardless of gc_flag,
605 because of the extra_branches argument now added to forkAlts.
607 We put a heap-check at the join point, for the benefit of constructors
608 which don't need to do allocation. This means that ones which do need
609 to allocate may end up doing two heap-checks; but that's just too bad.
610 (We'd need two join labels otherwise. ToDo.)
612 It's all pretty turgid anyway.
615 cgAlgAlts gc_flag uniq restore_cc semi_tagging
616 ty alts deflt@(StgBindDefault binder True{-used-} _)
617 emit_yield{-should a yield macro be emitted?-}
619 extra_branches :: [FCode (ConTag, AbstractC)]
620 extra_branches = catMaybes (map mk_extra_branch default_cons)
622 must_label_default = semi_tagging || not (null extra_branches)
624 forkAlts (map (cgAlgAlt gc_flag uniq restore_cc semi_tagging emit_yield) alts)
626 (cgAlgDefault gc_flag uniq restore_cc must_label_default deflt emit_yield)
629 default_join_lbl = mkDefaultLabel uniq
630 jump_instruction = CJump (CLbl default_join_lbl CodePtrRep)
632 (spec_tycon, _, spec_cons) = getAppSpecDataTyConExpandingDicts ty
634 alt_cons = [ con | (con,_,_,_) <- alts ]
636 default_cons = [ spec_con | spec_con <- spec_cons, -- In this type
637 spec_con `not_elem` alt_cons ] -- Not handled explicitly
639 not_elem = isn'tIn "cgAlgAlts"
641 -- (mk_extra_branch con) returns the a maybe for the extra branch for con.
642 -- The "maybe" is because con may return in heap, in which case there is
643 -- nothing to do. Otherwise, we have a special case for a nullary constructor,
644 -- but in the general case we do an allocation and heap-check.
646 mk_extra_branch :: DataCon -> (Maybe (FCode (ConTag, AbstractC)))
649 = ASSERT(isDataCon con)
650 case dataReturnConvAlg con of
651 ReturnInHeap -> Nothing
652 ReturnInRegs rs -> Just (getAbsC (alloc_code rs) `thenFC` \ abs_c ->
653 returnFC (tag, abs_c)
656 lf_info = mkConLFInfo con
659 -- alloc_code generates code to allocate constructor con, whose args are
660 -- in the arguments to alloc_code, assigning the result to Node.
661 alloc_code :: [MagicId] -> Code
664 = possibleHeapCheck gc_flag regs False (
665 buildDynCon binder useCurrentCostCentre con
666 (map CReg regs) (all zero_size regs)
668 idInfoToAmode PtrRep idinfo `thenFC` \ amode ->
670 absC (CAssign (CReg node) amode) `thenC`
671 absC jump_instruction
674 zero_size reg = getPrimRepSize (magicIdPrimRep reg) == 0
677 Now comes the general case
680 cgAlgAlts gc_flag uniq restore_cc must_label_branches ty alts deflt
681 {- The deflt is either StgNoDefault or a BindDefault which doesn't use the binder -}
682 emit_yield{-should a yield macro be emitted?-}
684 = forkAlts (map (cgAlgAlt gc_flag uniq restore_cc must_label_branches emit_yield) alts)
685 [{- No "extra branches" -}]
686 (cgAlgDefault gc_flag uniq restore_cc must_label_branches deflt emit_yield)
690 cgAlgDefault :: GCFlag
691 -> Unique -> AbstractC -> Bool -- turgid state...
692 -> StgCaseDefault -- input
694 -> FCode AbstractC -- output
696 cgAlgDefault gc_flag uniq restore_cc must_label_branch
700 cgAlgDefault gc_flag uniq restore_cc must_label_branch
701 (StgBindDefault _ False{-binder not used-} rhs)
702 emit_yield{-should a yield macro be emitted?-}
704 = getAbsC (absC restore_cc `thenC`
706 emit_gran_macros = opt_GranMacros
708 (if emit_gran_macros && emit_yield
710 else absC AbsCNop) `thenC`
711 -- liveness same as in possibleHeapCheck below
712 possibleHeapCheck gc_flag [] False (cgExpr rhs)) `thenFC` \ abs_c ->
714 final_abs_c | must_label_branch = CJump (CLabelledCode lbl abs_c)
719 lbl = mkDefaultLabel uniq
722 cgAlgDefault gc_flag uniq restore_cc must_label_branch
723 (StgBindDefault binder True{-binder used-} rhs)
724 emit_yield{-should a yield macro be emitted?-}
726 = -- We have arranged that Node points to the thing, even
727 -- even if we return in registers
728 bindNewToReg binder node mkLFArgument `thenC`
729 getAbsC (absC restore_cc `thenC`
731 emit_gran_macros = opt_GranMacros
733 (if emit_gran_macros && emit_yield
734 then yield [node] False
735 else absC AbsCNop) `thenC`
736 -- liveness same as in possibleHeapCheck below
737 possibleHeapCheck gc_flag [node] False (cgExpr rhs)
738 -- Node is live, but doesn't need to point at the thing itself;
739 -- it's ok for Node to point to an indirection or FETCH_ME
740 -- Hence no need to re-enter Node.
741 ) `thenFC` \ abs_c ->
744 final_abs_c | must_label_branch = CJump (CLabelledCode lbl abs_c)
749 lbl = mkDefaultLabel uniq
751 -- HWL comment on GrAnSim: GRAN_YIELDs needed; emitted in cgAlgAltRhs
754 -> Unique -> AbstractC -> Bool -- turgid state
755 -> Bool -- Context switch at alts?
756 -> (Id, [Id], [Bool], StgExpr)
757 -> FCode (ConTag, AbstractC)
759 cgAlgAlt gc_flag uniq restore_cc must_label_branch
760 emit_yield{-should a yield macro be emitted?-}
761 (con, args, use_mask, rhs)
762 = getAbsC (absC restore_cc `thenC`
763 cgAlgAltRhs gc_flag con args use_mask rhs
765 ) `thenFC` \ abs_c ->
767 final_abs_c | must_label_branch = CJump (CLabelledCode lbl abs_c)
770 returnFC (tag, final_abs_c)
773 lbl = mkAltLabel uniq tag
775 cgAlgAltRhs :: GCFlag
780 -> Bool -- context switch?
782 cgAlgAltRhs gc_flag con args use_mask rhs emit_yield
784 (live_regs, node_reqd)
785 = case (dataReturnConvAlg con) of
786 ReturnInHeap -> ([], True)
787 ReturnInRegs regs -> ([reg | (reg,True) <- zipEqual "cgAlgAltRhs" regs use_mask], False)
788 -- Pick the live registers using the use_mask
789 -- Doing so is IMPORTANT, because with semi-tagging
790 -- enabled only the live registers will have valid
794 emit_gran_macros = opt_GranMacros
796 (if emit_gran_macros && emit_yield
797 then yield live_regs node_reqd
798 else absC AbsCNop) `thenC`
799 -- liveness same as in possibleHeapCheck below
800 possibleHeapCheck gc_flag live_regs node_reqd (
802 NoGC -> mapFCs bindNewToTemp args `thenFC` \ _ ->
804 GCMayHappen -> bindConArgs con args
810 %************************************************************************
812 \subsection[CgCase-semi-tagged-alts]{The code to deal with sem-tagging}
814 %************************************************************************
816 Turgid-but-non-monadic code to conjure up the required info from
817 algebraic case alternatives for semi-tagging.
820 cgSemiTaggedAlts :: Unique
821 -> [(Id, [Id], [Bool], StgExpr)]
822 -> GenStgCaseDefault Id Id
825 cgSemiTaggedAlts uniq alts deflt
826 = Just (map st_alt alts, st_deflt deflt)
828 st_deflt StgNoDefault = Nothing
830 st_deflt (StgBindDefault binder binder_used _)
831 = Just (if binder_used then Just binder else Nothing,
832 (CCallProfCtrMacro SLIT("RET_SEMI_BY_DEFAULT") [], -- ToDo: monadise?
836 st_alt (con, args, use_mask, _)
837 = case (dataReturnConvAlg con) of
840 -- Ha! Nothing to do; Node already points to the thing
842 (CCallProfCtrMacro SLIT("RET_SEMI_IN_HEAP") -- ToDo: monadise?
843 [mkIntCLit (length args)], -- how big the thing in the heap is
848 -- We have to load the live registers from the constructor
849 -- pointed to by Node.
851 (_, regs_w_offsets) = layOutDynCon con magicIdPrimRep regs
853 used_regs = selectByMask use_mask regs
855 used_regs_w_offsets = [ ro | ro@(reg,offset) <- regs_w_offsets,
856 reg `is_elem` used_regs]
858 is_elem = isIn "cgSemiTaggedAlts"
862 CCallProfCtrMacro SLIT("RET_SEMI_IN_REGS") -- ToDo: macroise?
863 [mkIntCLit (length regs_w_offsets),
864 mkIntCLit (length used_regs_w_offsets)],
865 CSimultaneous (mkAbstractCs (map move_to_reg used_regs_w_offsets))],
868 con_tag = dataConTag con
869 join_label = mkAltLabel uniq con_tag
871 move_to_reg :: (MagicId, VirtualHeapOffset {-from Node-}) -> AbstractC
872 move_to_reg (reg, offset)
873 = CAssign (CReg reg) (CVal (NodeRel offset) (magicIdPrimRep reg))
876 %************************************************************************
878 \subsection[CgCase-prim-alts]{Primitive alternatives}
880 %************************************************************************
882 @cgPrimAlts@ generates a suitable @CSwitch@ for dealing with the
883 alternatives of a primitive @case@, given an addressing mode for the
884 thing to scrutinise. It also keeps track of the maximum stack depth
885 encountered down any branch.
887 As usual, no binders in the alternatives are yet bound.
893 -> [(Literal, StgExpr)] -- Alternatives
894 -> StgCaseDefault -- Default
897 cgPrimAlts gc_flag uniq ty alts deflt
898 = cgPrimAltsGivenScrutinee gc_flag scrutinee alts deflt
900 -- A temporary variable, or standard register, to hold the result
901 scrutinee = case gc_flag of
902 NoGC -> CTemp uniq kind
903 GCMayHappen -> CReg (dataReturnConvPrim kind)
905 kind = typePrimRep ty
908 cgPrimAltsGivenScrutinee gc_flag scrutinee alts deflt
909 = forkAlts (map (cgPrimAlt gc_flag) alts)
910 [{- No "extra branches" -}]
911 (cgPrimDefault gc_flag scrutinee deflt) `thenFC` \ (alt_absCs, deflt_absC) ->
912 absC (CSwitch scrutinee alt_absCs deflt_absC)
913 -- CSwitch does sensible things with one or zero alternatives
917 -> (Literal, StgExpr) -- The alternative
918 -> FCode (Literal, AbstractC) -- Its compiled form
920 cgPrimAlt gc_flag (lit, rhs)
921 = getAbsC rhs_code `thenFC` \ absC ->
924 rhs_code = possibleHeapCheck gc_flag [] False (cgExpr rhs )
926 cgPrimDefault :: GCFlag
927 -> CAddrMode -- Scrutinee
931 cgPrimDefault gc_flag scrutinee StgNoDefault
932 = panic "cgPrimDefault: No default in prim case"
934 cgPrimDefault gc_flag scrutinee (StgBindDefault _ False{-binder not used-} rhs)
935 = getAbsC (possibleHeapCheck gc_flag [] False (cgExpr rhs ))
937 cgPrimDefault gc_flag scrutinee (StgBindDefault binder True{-used-} rhs)
938 = getAbsC (possibleHeapCheck gc_flag regs False rhs_code)
940 regs = if isFollowableRep (getAmodeRep scrutinee) then
943 rhs_code = bindNewPrimToAmode binder scrutinee `thenC`
948 %************************************************************************
950 \subsection[CgCase-tidy]{Code for tidying up prior to an eval}
952 %************************************************************************
955 saveVolatileVarsAndRegs
956 :: StgLiveVars -- Vars which should be made safe
957 -> FCode (AbstractC, -- Assignments to do the saves
958 EndOfBlockInfo, -- New sequel, recording where the return
960 Maybe VirtualSpBOffset) -- Slot for current cost centre
963 saveVolatileVarsAndRegs vars
964 = saveVolatileVars vars `thenFC` \ var_saves ->
965 saveCurrentCostCentre `thenFC` \ (maybe_cc_slot, cc_save) ->
966 saveReturnAddress `thenFC` \ (new_eob_info, ret_save) ->
967 returnFC (mkAbstractCs [var_saves, cc_save, ret_save],
972 saveVolatileVars :: StgLiveVars -- Vars which should be made safe
973 -> FCode AbstractC -- Assignments to to the saves
975 saveVolatileVars vars
976 = save_em (idSetToList vars)
978 save_em [] = returnFC AbsCNop
981 = getCAddrModeIfVolatile var `thenFC` \ v ->
983 Nothing -> save_em vars -- Non-volatile, so carry on
986 Just vol_amode -> -- Aha! It's volatile
987 save_var var vol_amode `thenFC` \ abs_c ->
988 save_em vars `thenFC` \ abs_cs ->
989 returnFC (abs_c `mkAbsCStmts` abs_cs)
991 save_var var vol_amode
992 | isFollowableRep kind
993 = allocAStack `thenFC` \ a_slot ->
994 rebindToAStack var a_slot `thenC`
995 getSpARelOffset a_slot `thenFC` \ spa_rel ->
996 returnFC (CAssign (CVal spa_rel kind) vol_amode)
998 = allocBStack (getPrimRepSize kind) `thenFC` \ b_slot ->
999 rebindToBStack var b_slot `thenC`
1000 getSpBRelOffset b_slot `thenFC` \ spb_rel ->
1001 returnFC (CAssign (CVal spb_rel kind) vol_amode)
1003 kind = getAmodeRep vol_amode
1005 saveReturnAddress :: FCode (EndOfBlockInfo, AbstractC)
1007 = getEndOfBlockInfo `thenFC` \ eob_info@(EndOfBlockInfo vA vB sequel) ->
1009 -- See if it is volatile
1011 InRetReg -> -- Yes, it's volatile
1012 allocBStack retPrimRepSize `thenFC` \ b_slot ->
1013 getSpBRelOffset b_slot `thenFC` \ spb_rel ->
1015 returnFC (EndOfBlockInfo vA vB (OnStack b_slot),
1016 CAssign (CVal spb_rel RetRep) (CReg RetReg))
1018 UpdateCode _ -> -- It's non-volatile all right, but we still need
1019 -- to allocate a B-stack slot for it, *solely* to make
1020 -- sure that update frames for different values do not
1021 -- appear adjacent on the B stack. This makes sure
1022 -- that B-stack squeezing works ok.
1024 allocBStack retPrimRepSize `thenFC` \ b_slot ->
1025 returnFC (eob_info, AbsCNop)
1027 other -> -- No, it's non-volatile, so do nothing
1028 returnFC (eob_info, AbsCNop)
1031 Note about B-stack squeezing. Consider the following:`
1033 y = [...] \u [] -> ...
1034 x = [y] \u [] -> case y of (a,b) -> a
1036 The code for x will push an update frame, and then enter y. The code
1037 for y will push another update frame. If the B-stack-squeezer then
1038 wakes up, it will see two update frames right on top of each other,
1039 and will combine them. This is WRONG, of course, because x's value is
1040 not the same as y's.
1042 The fix implemented above makes sure that we allocate an (unused)
1043 B-stack slot before entering y. You can think of this as holding the
1044 saved value of RetAddr, which (after pushing x's update frame will be
1045 some update code ptr). The compiler is clever enough to load the
1046 static update code ptr into RetAddr before entering ~a~, but the slot
1047 is still there to separate the update frames.
1049 When we save the current cost centre (which is done for lexical
1050 scoping), we allocate a free B-stack location, and return (a)~the
1051 virtual offset of the location, to pass on to the alternatives, and
1052 (b)~the assignment to do the save (just as for @saveVolatileVars@).
1055 saveCurrentCostCentre ::
1056 FCode (Maybe VirtualSpBOffset, -- Where we decide to store it
1057 -- Nothing if not lexical CCs
1058 AbstractC) -- Assignment to save it
1059 -- AbsCNop if not lexical CCs
1061 saveCurrentCostCentre
1063 doing_profiling = opt_SccProfilingOn
1065 if not doing_profiling then
1066 returnFC (Nothing, AbsCNop)
1068 allocBStack (getPrimRepSize CostCentreRep) `thenFC` \ b_slot ->
1069 getSpBRelOffset b_slot `thenFC` \ spb_rel ->
1070 returnFC (Just b_slot,
1071 CAssign (CVal spb_rel CostCentreRep) (CReg CurCostCentre))
1073 restoreCurrentCostCentre :: Maybe VirtualSpBOffset -> FCode AbstractC
1075 restoreCurrentCostCentre Nothing
1077 restoreCurrentCostCentre (Just b_slot)
1078 = getSpBRelOffset b_slot `thenFC` \ spb_rel ->
1079 freeBStkSlot b_slot `thenC`
1080 returnFC (CCallProfCCMacro SLIT("RESTORE_CCC") [CVal spb_rel CostCentreRep])
1081 -- we use the RESTORE_CCC macro, rather than just
1082 -- assigning into CurCostCentre, in case RESTORE_CCC
1083 -- has some sanity-checking in it.
1087 %************************************************************************
1089 \subsection[CgCase-return-vec]{Building a return vector}
1091 %************************************************************************
1093 Build a return vector, and return a suitable label addressing
1097 mkReturnVector :: Unique
1099 -> [(ConTag, AbstractC)] -- Branch codes
1100 -> AbstractC -- Default case
1103 mkReturnVector uniq ty tagged_alt_absCs deflt_absC
1105 (return_vec_amode, vtbl_body) = case (ctrlReturnConvAlg spec_tycon) of {
1107 UnvectoredReturn _ ->
1108 (CUnVecLbl ret_label vtbl_label,
1109 absC (CRetUnVector vtbl_label
1110 (CLabelledCode ret_label
1111 (mkAlgAltsCSwitch (CReg TagReg)
1114 VectoredReturn table_size ->
1115 (CLbl vtbl_label DataPtrRep,
1116 absC (CRetVector vtbl_label
1117 -- must restore cc before each alt, if required
1118 (map mk_vector_entry [fIRST_TAG .. (table_size+fIRST_TAG-1)])
1121 -- Leave nops and comments in for now; they are eliminated
1122 -- lazily as it's printed.
1123 -- (case (nonemptyAbsC deflt_absC) of
1124 -- Nothing -> AbsCNop
1129 returnFC return_vec_amode
1133 (spec_tycon,_,_) = case (maybeAppSpecDataTyConExpandingDicts ty) of -- *must* be a real "data" type constructor
1135 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)
1137 vtbl_label = mkVecTblLabel uniq
1138 ret_label = mkReturnPtLabel uniq
1140 mk_vector_entry :: ConTag -> Maybe CAddrMode
1142 = case [ absC | (t, absC) <- tagged_alt_absCs, t == tag ] of
1144 [absC] -> Just (CCode absC)
1145 _ -> panic "mkReturnVector: too many"
1148 %************************************************************************
1150 \subsection[CgCase-utils]{Utilities for handling case expressions}
1152 %************************************************************************
1154 @possibleHeapCheck@ tests a flag passed in to decide whether to
1155 do a heap check or not.
1158 possibleHeapCheck :: GCFlag -> [MagicId] -> Bool -> Code -> Code
1160 possibleHeapCheck GCMayHappen regs node_reqd code = heapCheck regs node_reqd code
1161 possibleHeapCheck NoGC _ _ code = code
1164 Select a restricted set of registers based on a usage mask.
1167 selectByMask [] [] = []
1168 selectByMask (True:ms) (x:xs) = x : selectByMask ms xs
1169 selectByMask (False:ms) (x:xs) = selectByMask ms xs