Add a class HasDynFlags(getDynFlags)
[ghc.git] / compiler / codeGen / CgCase.lhs
1 %
2 % (c) The University of Glasgow 2006
3 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 %
5
6 \begin{code}
7 {-# OPTIONS -fno-warn-tabs #-}
8 -- The above warning supression flag is a temporary kludge.
9 -- While working on this module you are encouraged to remove it and
10 -- detab the module (please do the detabbing in a separate patch). See
11 --     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces
12 -- for details
13
14 module CgCase ( cgCase, saveVolatileVarsAndRegs, 
15                 restoreCurrentCostCentre
16         ) where
17
18 #include "HsVersions.h"
19
20 import {-# SOURCE #-} CgExpr  ( cgExpr )
21
22 import CgMonad
23 import CgBindery
24 import CgCon
25 import CgHeapery
26 import CgCallConv
27 import CgStackery
28 import CgTailCall
29 import CgPrimOp
30 import CgForeignCall
31 import CgUtils
32 import CgProf
33 import CgInfoTbls
34
35 import ClosureInfo
36 import OldCmmUtils
37 import OldCmm
38
39 import StgSyn
40 import StaticFlags
41 import Id
42 import ForeignCall
43 import VarSet
44 import CoreSyn
45 import PrimOp
46 import Type
47 import TyCon
48 import Util
49 import Outputable
50 import FastString
51
52 import Control.Monad (when)
53 \end{code}
54
55 \begin{code}
56 data GCFlag
57   = GCMayHappen -- The scrutinee may involve GC, so everything must be
58                 -- tidy before the code for the scrutinee.
59
60   | NoGC        -- The scrutinee is a primitive value, or a call to a
61                 -- primitive op which does no GC.  Hence the case can
62                 -- be done inline, without tidying up first.
63 \end{code}
64
65 It is quite interesting to decide whether to put a heap-check
66 at the start of each alternative.  Of course we certainly have
67 to do so if the case forces an evaluation, or if there is a primitive
68 op which can trigger GC.
69
70 A more interesting situation is this:
71
72  \begin{verbatim}
73         !A!;
74         ...A...
75         case x# of
76           0#      -> !B!; ...B...
77           default -> !C!; ...C...
78  \end{verbatim}
79
80 where \tr{!x!} indicates a possible heap-check point. The heap checks
81 in the alternatives {\em can} be omitted, in which case the topmost
82 heapcheck will take their worst case into account.
83
84 In favour of omitting \tr{!B!}, \tr{!C!}:
85
86  - {\em May} save a heap overflow test,
87         if ...A... allocates anything.  The other advantage
88         of this is that we can use relative addressing
89         from a single Hp to get at all the closures so allocated.
90
91  - No need to save volatile vars etc across the case
92
93 Against:
94
95   - May do more allocation than reqd.  This sometimes bites us
96         badly.  For example, nfib (ha!)  allocates about 30\% more space if the
97         worst-casing is done, because many many calls to nfib are leaf calls
98         which don't need to allocate anything.
99
100         This never hurts us if there is only one alternative.
101
102 \begin{code}
103 cgCase  :: StgExpr
104         -> StgLiveVars
105         -> StgLiveVars
106         -> Id
107         -> AltType
108         -> [StgAlt]
109         -> Code
110 \end{code}
111
112 Special case #1: case of literal.
113
114 \begin{code}
115 cgCase (StgLit lit) _live_in_whole_case _live_in_alts bndr
116        alt_type@(PrimAlt _) alts
117   = do  { tmp_reg <- bindNewToTemp bndr
118         ; cm_lit <- cgLit lit
119         ; stmtC (CmmAssign (CmmLocal tmp_reg) (CmmLit cm_lit))
120         ; cgPrimAlts NoGC alt_type (CmmLocal tmp_reg) alts }
121 \end{code}
122
123 Special case #2: scrutinising a primitive-typed variable.       No
124 evaluation required.  We don't save volatile variables, nor do we do a
125 heap-check in the alternatives.  Instead, the heap usage of the
126 alternatives is worst-cased and passed upstream.  This can result in
127 allocating more heap than strictly necessary, but it will sometimes
128 eliminate a heap check altogether.
129
130 \begin{code}
131 cgCase (StgApp _v []) _live_in_whole_case _live_in_alts bndr
132        (PrimAlt _) [(DEFAULT,bndrs,_,rhs)]
133   | isVoidArg (idCgRep bndr)
134   = ASSERT( null bndrs )
135     WARN( True, ptext (sLit "Case of void constant; missing optimisation somewhere") <+> ppr bndr)
136     cgExpr rhs
137
138 cgCase (StgApp v []) _live_in_whole_case _live_in_alts bndr
139        alt_type@(PrimAlt _) alts
140   -- Note [ticket #3132]: we might be looking at a case of a lifted Id
141   -- that was cast to an unlifted type.  The Id will always be bottom,
142   -- but we don't want the code generator to fall over here.  If we
143   -- just emit an assignment here, the assignment will be
144   -- type-incorrect Cmm.  Hence we check that the types match, and if
145   -- they don't we'll fall through and emit the usual enter/return
146   -- code.  Test case: codeGen/should_compile/3132.hs
147   | isUnLiftedType (idType v)
148
149   -- However, we also want to allow an assignment to be generated
150   -- in the case when the types are compatible, because this allows
151   -- some slightly-dodgy but occasionally-useful casts to be used,
152   -- such as in RtClosureInspect where we cast an HValue to a MutVar#
153   -- so we can print out the contents of the MutVar#.  If we generate
154   -- code that enters the HValue, then we'll get a runtime panic, because
155   -- the HValue really is a MutVar#.  The types are compatible though,
156   -- so we can just generate an assignment.
157   || reps_compatible
158   =  do { when (not reps_compatible) $
159             panic "cgCase: reps do not match, perhaps a dodgy unsafeCoerce?"
160
161           -- Careful! we can't just bind the default binder to the same thing
162           -- as the scrutinee, since it might be a stack location, and having
163           -- two bindings pointing at the same stack locn doesn't work (it
164           -- confuses nukeDeadBindings).  Hence, use a new temp.
165         ; v_info <- getCgIdInfo v
166         ; amode <- idInfoToAmode v_info
167         ; tmp_reg <- bindNewToTemp bndr
168         ; stmtC (CmmAssign (CmmLocal tmp_reg) amode)
169
170         ; cgPrimAlts NoGC alt_type (CmmLocal tmp_reg) alts }
171   where
172     reps_compatible = idCgRep v == idCgRep bndr
173 \end{code}
174
175 Special case #2.5; seq#
176
177   case seq# a s of v
178     (# s', a' #) -> e
179
180   ==>
181
182   case a of v
183     (# s', a' #) -> e
184
185   (taking advantage of the fact that the return convention for (# State#, a #)
186   is the same as the return convention for just 'a')
187
188 \begin{code}
189 cgCase (StgOpApp (StgPrimOp SeqOp) [StgVarArg a, _] _)
190        live_in_whole_case live_in_alts bndr alt_type alts
191   = cgCase (StgApp a []) live_in_whole_case live_in_alts bndr alt_type alts
192 \end{code}
193
194 Special case #3: inline PrimOps and foreign calls.
195
196 \begin{code}
197 cgCase (StgOpApp (StgPrimOp primop) args _) 
198        _live_in_whole_case live_in_alts bndr alt_type alts
199   | not (primOpOutOfLine primop)
200   = cgInlinePrimOp primop args bndr alt_type live_in_alts alts
201 \end{code}
202
203 TODO: Case-of-case of primop can probably be done inline too (but
204 maybe better to translate it out beforehand).  See
205 ghc/lib/misc/PackedString.lhs for examples where this crops up (with
206 4.02).
207
208 Special case #4: inline foreign calls: an unsafe foreign call can be done
209 right here, just like an inline primop.
210
211 \begin{code}
212 cgCase (StgOpApp (StgFCallOp fcall _) args _) 
213        _live_in_whole_case live_in_alts _bndr _alt_type alts
214   | unsafe_foreign_call
215   = ASSERT( isSingleton alts )
216     do  --  *must* be an unboxed tuple alt.
217         -- exactly like the cgInlinePrimOp case for unboxed tuple alts..
218         { res_tmps <- mapFCs bindNewToTemp non_void_res_ids
219         ; let res_hints = map (typeForeignHint.idType) non_void_res_ids
220         ; cgForeignCall (zipWith CmmHinted res_tmps res_hints) fcall args live_in_alts
221         ; cgExpr rhs }
222   where
223    (_, res_ids, _, rhs) = head alts
224    non_void_res_ids = filter (nonVoidArg . idCgRep) res_ids
225
226    unsafe_foreign_call
227          = case fcall of
228                 CCall (CCallSpec _ _ s) -> not (playSafe s)
229 \end{code}
230
231 Special case: scrutinising a non-primitive variable.
232 This can be done a little better than the general case, because
233 we can reuse/trim the stack slot holding the variable (if it is in one).
234
235 \begin{code}
236 cgCase (StgApp fun args)
237         _live_in_whole_case live_in_alts bndr alt_type alts
238   = do  { fun_info <- getCgIdInfo fun
239         ; arg_amodes <- getArgAmodes args
240
241         -- Nuking dead bindings *before* calculating the saves is the
242         -- value-add here.  We might end up freeing up some slots currently
243         -- occupied by variables only required for the call.
244         -- NOTE: we need to look up the variables used in the call before
245         -- doing this, because some of them may not be in the environment
246         -- afterward.
247         ; nukeDeadBindings live_in_alts 
248         ; (save_assts, alts_eob_info, maybe_cc_slot)
249                 <- saveVolatileVarsAndRegs live_in_alts
250
251         ; scrut_eob_info
252             <- forkEval alts_eob_info 
253                         (allocStackTop retAddrSizeW >> nopC)
254                         (do { deAllocStackTop retAddrSizeW
255                             ; cgEvalAlts maybe_cc_slot bndr alt_type alts })
256
257         ; setEndOfBlockInfo scrut_eob_info
258                             (performTailCall fun_info arg_amodes save_assts) }
259 \end{code}
260
261 Note about return addresses: we *always* push a return address, even
262 if because of an optimisation we end up jumping direct to the return
263 code (not through the address itself).  The alternatives always assume
264 that the return address is on the stack.  The return address is
265 required in case the alternative performs a heap check, since it
266 encodes the liveness of the slots in the activation record.
267
268 On entry to the case alternative, we can re-use the slot containing
269 the return address immediately after the heap check.  That's what the
270 deAllocStackTop call is doing above.
271
272 Finally, here is the general case.
273
274 \begin{code}
275 cgCase expr live_in_whole_case live_in_alts bndr alt_type alts
276   = do  {       -- Figure out what volatile variables to save
277           nukeDeadBindings live_in_whole_case
278     
279         ; (save_assts, alts_eob_info, maybe_cc_slot)
280                 <- saveVolatileVarsAndRegs live_in_alts
281
282              -- Save those variables right now!
283         ; emitStmts save_assts
284
285             -- generate code for the alts
286         ; scrut_eob_info
287                <- forkEval alts_eob_info
288                            (do  { nukeDeadBindings live_in_alts
289                                 ; allocStackTop retAddrSizeW   -- space for retn address 
290                                 ; nopC })
291                            (do  { deAllocStackTop retAddrSizeW
292                                 ; cgEvalAlts maybe_cc_slot bndr alt_type alts })
293
294         ; setEndOfBlockInfo scrut_eob_info (cgExpr expr)
295     }
296 \end{code}
297
298 There's a lot of machinery going on behind the scenes to manage the
299 stack pointer here.  forkEval takes the virtual Sp and free list from
300 the first argument, and turns that into the *real* Sp for the second
301 argument.  It also uses this virtual Sp as the args-Sp in the EOB info
302 returned, so that the scrutinee will trim the real Sp back to the
303 right place before doing whatever it does.  
304   --SDM (who just spent an hour figuring this out, and didn't want to 
305          forget it).
306
307 Why don't we push the return address just before evaluating the
308 scrutinee?  Because the slot reserved for the return address might
309 contain something useful, so we wait until performing a tail call or
310 return before pushing the return address (see
311 CgTailCall.pushReturnAddress).  
312
313 This also means that the environment doesn't need to know about the
314 free stack slot for the return address (for generating bitmaps),
315 because we don't reserve it until just before the eval.
316
317 TODO!!  Problem: however, we have to save the current cost centre
318 stack somewhere, because at the eval point the current CCS might be
319 different.  So we pick a free stack slot and save CCCS in it.  One
320 consequence of this is that activation records on the stack don't
321 follow the layout of closures when we're profiling.  The CCS could be
322 anywhere within the record).
323
324 %************************************************************************
325 %*                                                                      *
326                 Inline primops
327 %*                                                                      *
328 %************************************************************************
329
330 \begin{code}
331 cgInlinePrimOp :: PrimOp -> [StgArg] -> Id -> AltType -> StgLiveVars
332                -> [(AltCon, [Id], [Bool], StgExpr)]
333                -> Code
334 cgInlinePrimOp primop args bndr (PrimAlt _) live_in_alts alts
335   | isVoidArg (idCgRep bndr)
336   = ASSERT( con == DEFAULT && isSingleton alts && null bs )
337     do  {       -- VOID RESULT; just sequencing, 
338                 -- so get in there and do it
339                 -- The bndr should not occur, so no need to bind it
340           cgPrimOp [] primop args live_in_alts
341         ; cgExpr rhs }
342   where
343     (con,bs,_,rhs) = head alts
344
345 cgInlinePrimOp primop args bndr (PrimAlt tycon) live_in_alts alts
346   = do  {       -- PRIMITIVE ALTS, with non-void result
347           tmp_reg <- bindNewToTemp bndr
348         ; cgPrimOp [tmp_reg] primop args live_in_alts
349         ; cgPrimAlts NoGC (PrimAlt tycon) (CmmLocal tmp_reg) alts }
350
351 cgInlinePrimOp primop args _ (UbxTupAlt _) live_in_alts alts
352   = ASSERT( isSingleton alts )
353     do  {       -- UNBOXED TUPLE ALTS
354                 -- No heap check, no yield, just get in there and do it.
355                 -- NB: the case binder isn't bound to anything; 
356                 --     it has a unboxed tuple type
357           
358           res_tmps <- mapFCs bindNewToTemp non_void_res_ids
359         ; cgPrimOp res_tmps primop args live_in_alts
360         ; cgExpr rhs }
361   where
362    (_, res_ids, _, rhs) = head alts
363    non_void_res_ids = filter (nonVoidArg . idCgRep) res_ids
364
365 cgInlinePrimOp primop args bndr (AlgAlt tycon) live_in_alts alts
366   = do  {       -- ENUMERATION TYPE RETURN
367                 -- Typical: case a ># b of { True -> ..; False -> .. }
368                 -- The primop itself returns an index into the table of
369                 -- closures for the enumeration type.
370            tag_amode <- ASSERT( isEnumerationTyCon tycon )
371                         do_enum_primop primop
372
373                 -- Bind the default binder if necessary
374                 -- (avoiding it avoids the assignment)
375                 -- The deadness info is set by StgVarInfo
376         ; whenC (not (isDeadBinder bndr))
377                 (do { tmp_reg <- bindNewToTemp bndr
378                     ; stmtC (CmmAssign
379                              (CmmLocal tmp_reg)
380                              (tagToClosure tycon tag_amode)) })
381
382                 -- Compile the alts
383         ; (branches, mb_deflt) <- cgAlgAlts NoGC Nothing{-cc_slot-}
384                                             (AlgAlt tycon) alts
385
386                 -- Do the switch
387         ; emitSwitch tag_amode branches mb_deflt 0 (tyConFamilySize tycon - 1)
388         }
389   where
390
391     do_enum_primop :: PrimOp -> FCode CmmExpr   -- Returns amode for result
392     do_enum_primop TagToEnumOp  -- No code!
393        | [arg] <- args = do
394          (_,e) <- getArgAmode arg
395          return e
396     do_enum_primop primop
397       = do tmp <- newTemp bWord
398            cgPrimOp [tmp] primop args live_in_alts
399            returnFC (CmmReg (CmmLocal tmp))
400
401 cgInlinePrimOp _ _ bndr _ _ _
402   = pprPanic "cgCase: case of primop has polymorphic type" (ppr bndr)
403 \end{code}
404
405 %************************************************************************
406 %*                                                                      *
407 \subsection[CgCase-alts]{Alternatives}
408 %*                                                                      *
409 %************************************************************************
410
411 @cgEvalAlts@ returns an addressing mode for a continuation for the
412 alternatives of a @case@, used in a context when there
413 is some evaluation to be done.
414
415 \begin{code}
416 cgEvalAlts :: Maybe VirtualSpOffset     -- Offset of cost-centre to be restored, if any
417            -> Id
418            -> AltType
419            -> [StgAlt]
420            -> FCode Sequel      -- Any addr modes inside are guaranteed
421                                 -- to be a label so that we can duplicate it 
422                                 -- without risk of duplicating code
423
424 cgEvalAlts cc_slot bndr alt_type@(PrimAlt tycon) alts
425   = do  { let   rep = tyConCgRep tycon
426                 reg = dataReturnConvPrim rep    -- Bottom for voidRep
427
428         ; abs_c <- forkProc $ do
429                 {       -- Bind the case binder, except if it's void
430                         -- (reg is bottom in that case)
431                   whenC (nonVoidArg rep) $
432                   bindNewToReg bndr reg (mkLFArgument bndr)
433                 ; restoreCurrentCostCentre cc_slot True
434                 ; cgPrimAlts GCMayHappen alt_type reg alts }
435
436         ; lbl <- emitReturnTarget (idName bndr) abs_c
437         ; returnFC (CaseAlts lbl Nothing bndr) }
438
439 cgEvalAlts cc_slot bndr (UbxTupAlt _) [(con,args,_,rhs)]
440   =     -- Unboxed tuple case
441         -- By now, the simplifier should have have turned it
442         -- into         case e of (# a,b #) -> e
443         -- There shouldn't be a 
444         --              case e of DEFAULT -> e
445     ASSERT2( case con of { DataAlt _ -> True; _ -> False },
446              text "cgEvalAlts: dodgy case of unboxed tuple type" )
447     do  {       -- forkAbsC for the RHS, so that the envt is
448                 -- not changed for the emitReturn call
449           abs_c <- forkProc $ do 
450                 { (live_regs, ptrs, nptrs, _) <- bindUnboxedTupleComponents args
451                         -- Restore the CC *after* binding the tuple components, 
452                         -- so that we get the stack offset of the saved CC right.
453                 ; restoreCurrentCostCentre cc_slot True
454                         -- Generate a heap check if necessary
455                         -- and finally the code for the alternative
456                 ; unbxTupleHeapCheck live_regs ptrs nptrs noStmts
457                                      (cgExpr rhs) }
458         ; lbl <- emitReturnTarget (idName bndr) abs_c
459         ; returnFC (CaseAlts lbl Nothing bndr) }
460
461 cgEvalAlts cc_slot bndr alt_type alts
462   =     -- Algebraic and polymorphic case
463     do  {       -- Bind the default binder
464           bindNewToReg bndr nodeReg (mkLFArgument bndr)
465
466         -- Generate sequel info for use downstream
467         -- At the moment, we only do it if the type is vector-returnable.
468         -- Reason: if not, then it costs extra to label the
469         -- alternatives, because we'd get return code like:
470         --
471         --      switch TagReg { 0 : JMP(alt_1); 1 : JMP(alt_2) ..etc }
472         --
473         -- which is worse than having the alt code in the switch statement
474
475         ; (alts, mb_deflt) <- cgAlgAlts GCMayHappen cc_slot alt_type alts
476
477         ; (lbl, branches) <- emitAlgReturnTarget (idName bndr) 
478                                 alts mb_deflt fam_sz
479
480         ; returnFC (CaseAlts lbl branches bndr) }
481   where
482     fam_sz = case alt_type of
483                 AlgAlt tc -> tyConFamilySize tc
484                 PolyAlt   -> 0
485                 PrimAlt _ -> panic "cgEvalAlts: PrimAlt"
486                 UbxTupAlt _ -> panic "cgEvalAlts: UbxTupAlt"
487 \end{code}
488
489
490 HWL comment on {\em GrAnSim\/}  (adding GRAN_YIELDs for context switch): If
491 we  do  an inlining of the  case  no separate  functions  for returning are
492 created, so we don't have to generate a GRAN_YIELD in that case.  This info
493 must be  propagated  to cgAlgAltRhs (where the  GRAN_YIELD  macro might  be
494 emitted). Hence, the new Bool arg to cgAlgAltRhs.
495
496 %************************************************************************
497 %*                                                                      *
498 \subsection[CgCase-alg-alts]{Algebraic alternatives}
499 %*                                                                      *
500 %************************************************************************
501
502 In @cgAlgAlts@, none of the binders in the alternatives are
503 assumed to be yet bound.
504
505 HWL comment on {\em GrAnSim\/} (adding GRAN_YIELDs for context switch): The
506 last   arg of  cgAlgAlts  indicates  if we  want  a context   switch at the
507 beginning of  each alternative. Normally we  want that. The  only exception
508 are inlined alternatives.
509
510 \begin{code}
511 cgAlgAlts :: GCFlag
512        -> Maybe VirtualSpOffset
513        -> AltType                               --  ** AlgAlt or PolyAlt only **
514        -> [StgAlt]                              -- The alternatives
515        -> FCode ( [(ConTagZ, CgStmts)], -- The branches
516                   Maybe CgStmts )       -- The default case
517
518 cgAlgAlts gc_flag cc_slot alt_type alts
519   = do alts <- forkAlts [ cgAlgAlt gc_flag cc_slot alt_type alt | alt <- alts]
520        let
521             mb_deflt = case alts of -- DEFAULT is always first, if present
522                          ((DEFAULT,blks) : _) -> Just blks
523                          _                    -> Nothing
524
525             branches = [(dataConTagZ con, blks) 
526                        | (DataAlt con, blks) <- alts]
527        -- in
528        return (branches, mb_deflt)
529
530
531 cgAlgAlt :: GCFlag
532          -> Maybe VirtualSpOffset       -- Turgid state
533          -> AltType                     --  ** AlgAlt or PolyAlt only **
534          -> StgAlt
535          -> FCode (AltCon, CgStmts)
536
537 cgAlgAlt gc_flag cc_slot alt_type (con, args, _use_mask, rhs)
538   = do  { abs_c <- getCgStmts $ do
539                 { bind_con_args con args
540                 ; restoreCurrentCostCentre cc_slot True
541                 ; maybeAltHeapCheck gc_flag alt_type (cgExpr rhs) }
542         ; return (con, abs_c) }
543   where
544     bind_con_args DEFAULT      _    = nopC
545     bind_con_args (DataAlt dc) args = bindConArgs dc args
546     bind_con_args (LitAlt _)   _    = panic "cgAlgAlt: LitAlt"
547 \end{code}
548
549
550 %************************************************************************
551 %*                                                                      *
552 \subsection[CgCase-prim-alts]{Primitive alternatives}
553 %*                                                                      *
554 %************************************************************************
555
556 @cgPrimAlts@ generates suitable a @CSwitch@
557 for dealing with the alternatives of a primitive @case@, given an
558 addressing mode for the thing to scrutinise.  It also keeps track of
559 the maximum stack depth encountered down any branch.
560
561 As usual, no binders in the alternatives are yet bound.
562
563 \begin{code}
564 cgPrimAlts :: GCFlag
565            -> AltType   -- Always PrimAlt, but passed to maybeAltHeapCheck
566            -> CmmReg    -- Scrutinee
567            -> [StgAlt]  -- Alternatives
568            -> Code
569 -- NB: cgPrimAlts emits code that does the case analysis.
570 -- It's often used in inline situations, rather than to genearte
571 -- a labelled return point.  That's why its interface is a little
572 -- different to cgAlgAlts
573 --
574 -- INVARIANT: the default binder is already bound
575 cgPrimAlts gc_flag alt_type scrutinee alts
576   = do  { tagged_absCs <- forkAlts (map (cgPrimAlt gc_flag alt_type) alts)
577         ; let ((DEFAULT, deflt_absC) : others) = tagged_absCs   -- There is always a default
578               alt_absCs = [(lit,rhs) | (LitAlt lit, rhs) <- others]
579         ; emitLitSwitch (CmmReg scrutinee) alt_absCs deflt_absC }
580
581 cgPrimAlt :: GCFlag
582           -> AltType
583           -> StgAlt                             -- The alternative
584           -> FCode (AltCon, CgStmts)    -- Its compiled form
585
586 cgPrimAlt gc_flag alt_type (con, [], [], rhs)
587   = ASSERT( case con of { DEFAULT -> True; LitAlt _ -> True; _ -> False } )
588     do  { abs_c <- getCgStmts (maybeAltHeapCheck gc_flag alt_type (cgExpr rhs)) 
589         ; returnFC (con, abs_c) }
590 cgPrimAlt _ _ _ = panic "cgPrimAlt: non-empty lists"
591 \end{code}
592
593
594 %************************************************************************
595 %*                                                                      *
596 \subsection[CgCase-tidy]{Code for tidying up prior to an eval}
597 %*                                                                      *
598 %************************************************************************
599
600 \begin{code}
601 maybeAltHeapCheck 
602         :: GCFlag 
603         -> AltType      -- PolyAlt, PrimAlt, AlgAlt, but *not* UbxTupAlt
604         -> Code         -- Continuation
605         -> Code
606 maybeAltHeapCheck NoGC        _        code = code
607 maybeAltHeapCheck GCMayHappen alt_type code = altHeapCheck alt_type code
608
609 saveVolatileVarsAndRegs
610     :: StgLiveVars                    -- Vars which should be made safe
611     -> FCode (CmmStmts,               -- Assignments to do the saves
612               EndOfBlockInfo,         -- sequel for the alts
613               Maybe VirtualSpOffset)  -- Slot for current cost centre
614
615 saveVolatileVarsAndRegs vars
616   = do  { var_saves <- saveVolatileVars vars
617         ; (maybe_cc_slot, cc_save) <- saveCurrentCostCentre
618         ; eob_info <- getEndOfBlockInfo
619         ; returnFC (var_saves `plusStmts` cc_save,
620                     eob_info,
621                     maybe_cc_slot) }
622
623
624 saveVolatileVars :: StgLiveVars         -- Vars which should be made safe
625                  -> FCode CmmStmts      -- Assignments to to the saves
626
627 saveVolatileVars vars
628   = do  { stmts_s <- mapFCs save_it (varSetElems vars)
629         ; return (foldr plusStmts noStmts stmts_s) }
630   where
631     save_it var
632       = do { v <- getCAddrModeIfVolatile var
633            ; case v of
634                 Nothing         -> return noStmts          -- Non-volatile
635                 Just vol_amode  -> save_var var vol_amode  -- Aha! It's volatile
636         }
637
638     save_var var vol_amode
639       = do { slot <- allocPrimStack (idCgRep var)
640            ; rebindToStack var slot
641            ; sp_rel <- getSpRelOffset slot
642            ; returnFC (oneStmt (CmmStore sp_rel vol_amode)) }
643 \end{code}
644
645 ---------------------------------------------------------------------------
646
647 When we save the current cost centre (which is done for lexical
648 scoping), we allocate a free stack location, and return (a)~the
649 virtual offset of the location, to pass on to the alternatives, and
650 (b)~the assignment to do the save (just as for @saveVolatileVars@).
651
652 \begin{code}
653 saveCurrentCostCentre ::
654         FCode (Maybe VirtualSpOffset,   -- Where we decide to store it
655                CmmStmts)                -- Assignment to save it
656
657 saveCurrentCostCentre
658   | not opt_SccProfilingOn 
659   = returnFC (Nothing, noStmts)
660   | otherwise
661   = do  { slot <- allocPrimStack PtrArg
662         ; sp_rel <- getSpRelOffset slot
663         ; returnFC (Just slot,
664                     oneStmt (CmmStore sp_rel curCCS)) }
665
666 -- Sometimes we don't free the slot containing the cost centre after restoring it
667 -- (see CgLetNoEscape.cgLetNoEscapeBody).
668 restoreCurrentCostCentre :: Maybe VirtualSpOffset -> Bool -> Code
669 restoreCurrentCostCentre Nothing     _freeit = nopC
670 restoreCurrentCostCentre (Just slot) freeit
671  = do   { sp_rel <- getSpRelOffset slot
672         ; whenC freeit (freeStackSlots [slot])
673         ; stmtC (storeCurCCS (CmmLoad sp_rel bWord)) }
674 \end{code}
675