2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 % $Id: CgCase.lhs,v 1.70 2004/08/13 13:25:45 simonmar Exp $
6 %********************************************************
8 \section[CgCase]{Converting @StgCase@ expressions}
10 %********************************************************
13 module CgCase ( cgCase, saveVolatileVarsAndRegs,
14 restoreCurrentCostCentre
17 #include "HsVersions.h"
19 import {-# SOURCE #-} CgExpr ( cgExpr )
23 import CgBindery ( getArgAmodes,
24 bindNewToReg, bindNewToTemp,
25 getCgIdInfo, getArgAmode,
26 rebindToStack, getCAddrModeIfVolatile,
27 nukeDeadBindings, idInfoToAmode
29 import CgCon ( bindConArgs, bindUnboxedTupleComponents )
30 import CgHeapery ( altHeapCheck, unbxTupleHeapCheck )
31 import CgCallConv ( dataReturnConvPrim, ctrlReturnConvAlg,
32 CtrlReturnConvention(..)
34 import CgStackery ( allocPrimStack, allocStackTop, getSpRelOffset,
35 deAllocStackTop, freeStackSlots
37 import CgTailCall ( performTailCall )
38 import CgPrimOp ( cgPrimOp )
39 import CgForeignCall ( cgForeignCall )
40 import CgUtils ( newTemp, cgLit, emitLitSwitch, emitSwitch,
42 import CgProf ( curCCS, curCCSAddr )
43 import CgInfoTbls ( emitDirectReturnTarget, emitAlgReturnTarget,
45 import SMRep ( CgRep(..), retAddrSizeW, nonVoidArg, isVoidArg,
46 idCgRep, tyConCgRep, typeHint )
47 import CmmUtils ( CmmStmts, noStmts, oneStmt, plusStmts )
49 import MachOp ( wordRep )
50 import ClosureInfo ( mkLFArgument )
51 import CmdLineOpts ( opt_SccProfilingOn )
52 import Id ( Id, idName, isDeadBinder, idType )
53 import ForeignCall ( ForeignCall(..), CCallSpec(..), playSafe )
54 import VarSet ( varSetElems )
55 import CoreSyn ( AltCon(..) )
56 import PrimOp ( PrimOp(..), primOpOutOfLine )
57 import TyCon ( isEnumerationTyCon, tyConFamilySize )
58 import Util ( isSingleton )
64 = GCMayHappen -- The scrutinee may involve GC, so everything must be
65 -- tidy before the code for the scrutinee.
67 | NoGC -- The scrutinee is a primitive value, or a call to a
68 -- primitive op which does no GC. Hence the case can
69 -- be done inline, without tidying up first.
72 It is quite interesting to decide whether to put a heap-check
73 at the start of each alternative. Of course we certainly have
74 to do so if the case forces an evaluation, or if there is a primitive
75 op which can trigger GC.
77 A more interesting situation is this:
84 default -> !C!; ...C...
87 where \tr{!x!} indicates a possible heap-check point. The heap checks
88 in the alternatives {\em can} be omitted, in which case the topmost
89 heapcheck will take their worst case into account.
91 In favour of omitting \tr{!B!}, \tr{!C!}:
93 - {\em May} save a heap overflow test,
94 if ...A... allocates anything. The other advantage
95 of this is that we can use relative addressing
96 from a single Hp to get at all the closures so allocated.
98 - No need to save volatile vars etc across the case
102 - May do more allocation than reqd. This sometimes bites us
103 badly. For example, nfib (ha!) allocates about 30\% more space if the
104 worst-casing is done, because many many calls to nfib are leaf calls
105 which don't need to allocate anything.
107 This never hurts us if there is only one alternative.
120 Special case #1: case of literal.
123 cgCase (StgLit lit) live_in_whole_case live_in_alts bndr srt
124 alt_type@(PrimAlt tycon) alts
125 = do { tmp_reg <- bindNewToTemp bndr
126 ; cm_lit <- cgLit lit
127 ; stmtC (CmmAssign tmp_reg (CmmLit cm_lit))
128 ; cgPrimAlts NoGC alt_type tmp_reg alts }
131 Special case #2: scrutinising a primitive-typed variable. No
132 evaluation required. We don't save volatile variables, nor do we do a
133 heap-check in the alternatives. Instead, the heap usage of the
134 alternatives is worst-cased and passed upstream. This can result in
135 allocating more heap than strictly necessary, but it will sometimes
136 eliminate a heap check altogether.
139 cgCase (StgApp v []) live_in_whole_case live_in_alts bndr srt
140 alt_type@(PrimAlt tycon) alts
141 = do { -- Careful! we can't just bind the default binder to the same thing
142 -- as the scrutinee, since it might be a stack location, and having
143 -- two bindings pointing at the same stack locn doesn't work (it
144 -- confuses nukeDeadBindings). Hence, use a new temp.
145 v_info <- getCgIdInfo v
146 ; amode <- idInfoToAmode v_info
147 ; tmp_reg <- bindNewToTemp bndr
148 ; stmtC (CmmAssign tmp_reg amode)
149 ; cgPrimAlts NoGC alt_type tmp_reg alts }
152 Special case #3: inline PrimOps and foreign calls.
155 cgCase (StgOpApp op@(StgPrimOp primop) args _)
156 live_in_whole_case live_in_alts bndr srt alt_type alts
157 | not (primOpOutOfLine primop)
158 = cgInlinePrimOp primop args bndr alt_type live_in_alts alts
161 TODO: Case-of-case of primop can probably be done inline too (but
162 maybe better to translate it out beforehand). See
163 ghc/lib/misc/PackedString.lhs for examples where this crops up (with
166 Special case #4: inline foreign calls: an unsafe foreign call can be done
167 right here, just like an inline primop.
170 cgCase (StgOpApp op@(StgFCallOp fcall _) args _)
171 live_in_whole_case live_in_alts bndr srt alt_type alts
172 | unsafe_foreign_call
173 = ASSERT( isSingleton alts )
174 do -- *must* be an unboxed tuple alt.
175 -- exactly like the cgInlinePrimOp case for unboxed tuple alts..
176 { res_tmps <- mapFCs bindNewToTemp non_void_res_ids
177 ; let res_hints = map (typeHint.idType) non_void_res_ids
178 ; cgForeignCall (zip res_tmps res_hints) fcall args live_in_alts
181 (_, res_ids, _, rhs) = head alts
182 non_void_res_ids = filter (nonVoidArg . idCgRep) res_ids
186 CCall (CCallSpec _ _ s) -> not (playSafe s)
190 Special case: scrutinising a non-primitive variable.
191 This can be done a little better than the general case, because
192 we can reuse/trim the stack slot holding the variable (if it is in one).
195 cgCase (StgApp fun args)
196 live_in_whole_case live_in_alts bndr srt alt_type alts
197 = do { fun_info <- getCgIdInfo fun
198 ; arg_amodes <- getArgAmodes args
200 -- Nuking dead bindings *before* calculating the saves is the
201 -- value-add here. We might end up freeing up some slots currently
202 -- occupied by variables only required for the call.
203 -- NOTE: we need to look up the variables used in the call before
204 -- doing this, because some of them may not be in the environment
206 ; nukeDeadBindings live_in_alts
207 ; (save_assts, alts_eob_info, maybe_cc_slot)
208 <- saveVolatileVarsAndRegs live_in_alts
211 <- forkEval alts_eob_info
212 (allocStackTop retAddrSizeW >> nopC)
213 (do { deAllocStackTop retAddrSizeW
214 ; cgEvalAlts maybe_cc_slot bndr srt alt_type alts })
216 ; setEndOfBlockInfo (maybeReserveSeqFrame alt_type scrut_eob_info)
217 (performTailCall fun_info arg_amodes save_assts) }
220 Note about return addresses: we *always* push a return address, even
221 if because of an optimisation we end up jumping direct to the return
222 code (not through the address itself). The alternatives always assume
223 that the return address is on the stack. The return address is
224 required in case the alternative performs a heap check, since it
225 encodes the liveness of the slots in the activation record.
227 On entry to the case alternative, we can re-use the slot containing
228 the return address immediately after the heap check. That's what the
229 deAllocStackTop call is doing above.
231 Finally, here is the general case.
234 cgCase expr live_in_whole_case live_in_alts bndr srt alt_type alts
235 = do { -- Figure out what volatile variables to save
236 nukeDeadBindings live_in_whole_case
238 ; (save_assts, alts_eob_info, maybe_cc_slot)
239 <- saveVolatileVarsAndRegs live_in_alts
241 -- Save those variables right now!
242 ; emitStmts save_assts
244 -- generate code for the alts
246 <- forkEval alts_eob_info
247 (do { nukeDeadBindings live_in_alts
248 ; allocStackTop retAddrSizeW -- space for retn address
250 (do { deAllocStackTop retAddrSizeW
251 ; cgEvalAlts maybe_cc_slot bndr srt alt_type alts })
253 ; setEndOfBlockInfo (maybeReserveSeqFrame alt_type scrut_eob_info)
258 There's a lot of machinery going on behind the scenes to manage the
259 stack pointer here. forkEval takes the virtual Sp and free list from
260 the first argument, and turns that into the *real* Sp for the second
261 argument. It also uses this virtual Sp as the args-Sp in the EOB info
262 returned, so that the scrutinee will trim the real Sp back to the
263 right place before doing whatever it does.
264 --SDM (who just spent an hour figuring this out, and didn't want to
267 Why don't we push the return address just before evaluating the
268 scrutinee? Because the slot reserved for the return address might
269 contain something useful, so we wait until performing a tail call or
270 return before pushing the return address (see
271 CgTailCall.pushReturnAddress).
273 This also means that the environment doesn't need to know about the
274 free stack slot for the return address (for generating bitmaps),
275 because we don't reserve it until just before the eval.
277 TODO!! Problem: however, we have to save the current cost centre
278 stack somewhere, because at the eval point the current CCS might be
279 different. So we pick a free stack slot and save CCCS in it. One
280 consequence of this is that activation records on the stack don't
281 follow the layout of closures when we're profiling. The CCS could be
282 anywhere within the record).
285 maybeReserveSeqFrame PolyAlt (EndOfBlockInfo args_sp (CaseAlts amode stuff bndr _))
286 = EndOfBlockInfo (args_sp + retAddrSizeW) (CaseAlts amode stuff bndr True)
287 maybeReserveSeqFrame other scrut_eob_info = scrut_eob_info
291 %************************************************************************
295 %************************************************************************
298 cgInlinePrimOp primop args bndr (PrimAlt tycon) live_in_alts alts
299 | isVoidArg (idCgRep bndr)
300 = ASSERT( con == DEFAULT && isSingleton alts && null bs )
301 do { -- VOID RESULT; just sequencing,
302 -- so get in there and do it
303 cgPrimOp [] primop args live_in_alts
306 (con,bs,_,rhs) = head alts
308 cgInlinePrimOp primop args bndr (PrimAlt tycon) live_in_alts alts
309 = do { -- PRIMITIVE ALTS, with non-void result
310 tmp_reg <- bindNewToTemp bndr
311 ; cgPrimOp [tmp_reg] primop args live_in_alts
312 ; cgPrimAlts NoGC (PrimAlt tycon) tmp_reg alts }
314 cgInlinePrimOp primop args bndr (UbxTupAlt tycon) live_in_alts alts
315 = ASSERT( isSingleton alts )
316 do { -- UNBOXED TUPLE ALTS
317 -- No heap check, no yield, just get in there and do it.
318 -- NB: the case binder isn't bound to anything;
319 -- it has a unboxed tuple type
321 res_tmps <- mapFCs bindNewToTemp non_void_res_ids
322 ; cgPrimOp res_tmps primop args live_in_alts
325 (_, res_ids, _, rhs) = head alts
326 non_void_res_ids = filter (nonVoidArg . idCgRep) res_ids
328 cgInlinePrimOp primop args bndr (AlgAlt tycon) live_in_alts alts
329 = do { -- ENUMERATION TYPE RETURN
330 -- Typical: case a ># b of { True -> ..; False -> .. }
331 -- The primop itself returns an index into the table of
332 -- closures for the enumeration type.
333 tag_amode <- ASSERT( isEnumerationTyCon tycon )
334 do_enum_primop primop
336 -- Bind the default binder if necessary
337 -- (avoiding it avoids the assignment)
338 -- The deadness info is set by StgVarInfo
339 ; whenC (not (isDeadBinder bndr))
340 (do { tmp_reg <- bindNewToTemp bndr
341 ; stmtC (CmmAssign tmp_reg (tagToClosure tycon tag_amode)) })
344 ; (branches, mb_deflt) <- cgAlgAlts NoGC Nothing{-cc_slot-}
348 ; emitSwitch tag_amode branches mb_deflt 0 (tyConFamilySize tycon - 1)
352 do_enum_primop :: PrimOp -> FCode CmmExpr -- Returns amode for result
353 do_enum_primop TagToEnumOp -- No code!
355 (_,e) <- getArgAmode arg
357 do_enum_primop primop
358 = do tmp <- newTemp wordRep
359 cgPrimOp [tmp] primop args live_in_alts
360 returnFC (CmmReg tmp)
362 cgInlinePrimOp primop arg_amodes bndr PolyAlt live_in_alts alts
363 = pprPanic "cgCase: case of primop has polymorphic type" (ppr bndr)
366 %************************************************************************
368 \subsection[CgCase-alts]{Alternatives}
370 %************************************************************************
372 @cgEvalAlts@ returns an addressing mode for a continuation for the
373 alternatives of a @case@, used in a context when there
374 is some evaluation to be done.
377 cgEvalAlts :: Maybe VirtualSpOffset -- Offset of cost-centre to be restored, if any
379 -> SRT -- SRT for the continuation
382 -> FCode Sequel -- Any addr modes inside are guaranteed
383 -- to be a label so that we can duplicate it
384 -- without risk of duplicating code
386 cgEvalAlts cc_slot bndr srt alt_type@(PrimAlt tycon) alts
387 = do { let rep = tyConCgRep tycon
388 reg = dataReturnConvPrim rep -- Bottom for voidRep
390 ; abs_c <- forkProc $ do
391 { -- Bind the case binder, except if it's void
392 -- (reg is bottom in that case)
393 whenC (nonVoidArg rep) $
394 bindNewToReg bndr reg (mkLFArgument bndr)
395 ; restoreCurrentCostCentre cc_slot True
396 ; cgPrimAlts GCMayHappen alt_type reg alts }
398 ; lbl <- emitDirectReturnTarget (idName bndr) abs_c srt
399 ; returnFC (CaseAlts lbl Nothing bndr False) }
401 cgEvalAlts cc_slot bndr srt (UbxTupAlt _) [(con,args,_,rhs)]
402 = -- Unboxed tuple case
403 -- By now, the simplifier should have have turned it
404 -- into case e of (# a,b #) -> e
405 -- There shouldn't be a
406 -- case e of DEFAULT -> e
407 ASSERT2( case con of { DataAlt _ -> True; other -> False },
408 text "cgEvalAlts: dodgy case of unboxed tuple type" )
409 do { -- forkAbsC for the RHS, so that the envt is
410 -- not changed for the emitDirectReturn call
411 abs_c <- forkProc $ do
412 { (live_regs, ptrs, nptrs, _) <- bindUnboxedTupleComponents args
413 -- Restore the CC *after* binding the tuple components,
414 -- so that we get the stack offset of the saved CC right.
415 ; restoreCurrentCostCentre cc_slot True
416 -- Generate a heap check if necessary
417 -- and finally the code for the alternative
418 ; unbxTupleHeapCheck live_regs ptrs nptrs noStmts
420 ; lbl <- emitDirectReturnTarget (idName bndr) abs_c srt
421 ; returnFC (CaseAlts lbl Nothing bndr False) }
423 cgEvalAlts cc_slot bndr srt alt_type alts
424 = -- Algebraic and polymorphic case
425 do { -- Bind the default binder
426 bindNewToReg bndr nodeReg (mkLFArgument bndr)
428 -- Generate sequel info for use downstream
429 -- At the moment, we only do it if the type is vector-returnable.
430 -- Reason: if not, then it costs extra to label the
431 -- alternatives, because we'd get return code like:
433 -- switch TagReg { 0 : JMP(alt_1); 1 : JMP(alt_2) ..etc }
435 -- which is worse than having the alt code in the switch statement
437 ; (alts, mb_deflt) <- cgAlgAlts GCMayHappen cc_slot alt_type alts
439 ; (lbl, branches) <- emitAlgReturnTarget (idName bndr)
440 alts mb_deflt srt ret_conv
442 ; returnFC (CaseAlts lbl branches bndr False) }
444 ret_conv = case alt_type of
445 AlgAlt tc -> ctrlReturnConvAlg tc
446 PolyAlt -> UnvectoredReturn 0
450 HWL comment on {\em GrAnSim\/} (adding GRAN_YIELDs for context switch): If
451 we do an inlining of the case no separate functions for returning are
452 created, so we don't have to generate a GRAN_YIELD in that case. This info
453 must be propagated to cgAlgAltRhs (where the GRAN_YIELD macro might be
454 emitted). Hence, the new Bool arg to cgAlgAltRhs.
456 %************************************************************************
458 \subsection[CgCase-alg-alts]{Algebraic alternatives}
460 %************************************************************************
462 In @cgAlgAlts@, none of the binders in the alternatives are
463 assumed to be yet bound.
465 HWL comment on {\em GrAnSim\/} (adding GRAN_YIELDs for context switch): The
466 last arg of cgAlgAlts indicates if we want a context switch at the
467 beginning of each alternative. Normally we want that. The only exception
468 are inlined alternatives.
472 -> Maybe VirtualSpOffset
473 -> AltType -- ** AlgAlt or PolyAlt only **
474 -> [StgAlt] -- The alternatives
475 -> FCode ( [(ConTagZ, CgStmts)], -- The branches
476 Maybe CgStmts ) -- The default case
478 cgAlgAlts gc_flag cc_slot alt_type alts
479 = do alts <- forkAlts [ cgAlgAlt gc_flag cc_slot alt_type alt | alt <- alts]
481 mb_deflt = case alts of -- DEFAULT is always first, if present
482 ((DEFAULT,blks) : _) -> Just blks
485 branches = [(dataConTagZ con, blks)
486 | (DataAlt con, blks) <- alts]
488 return (branches, mb_deflt)
492 -> Maybe VirtualSpOffset -- Turgid state
493 -> AltType -- ** AlgAlt or PolyAlt only **
495 -> FCode (AltCon, CgStmts)
497 cgAlgAlt gc_flag cc_slot alt_type (con, args, use_mask, rhs)
498 = do { abs_c <- getCgStmts $ do
499 { bind_con_args con args
500 ; restoreCurrentCostCentre cc_slot True
501 ; maybeAltHeapCheck gc_flag alt_type (cgExpr rhs) }
502 ; return (con, abs_c) }
504 bind_con_args DEFAULT args = nopC
505 bind_con_args (DataAlt dc) args = bindConArgs dc args
509 %************************************************************************
511 \subsection[CgCase-prim-alts]{Primitive alternatives}
513 %************************************************************************
515 @cgPrimAlts@ generates suitable a @CSwitch@
516 for dealing with the alternatives of a primitive @case@, given an
517 addressing mode for the thing to scrutinise. It also keeps track of
518 the maximum stack depth encountered down any branch.
520 As usual, no binders in the alternatives are yet bound.
524 -> AltType -- Always PrimAlt, but passed to maybeAltHeapCheck
525 -> CmmReg -- Scrutinee
526 -> [StgAlt] -- Alternatives
528 -- NB: cgPrimAlts emits code that does the case analysis.
529 -- It's often used in inline situations, rather than to genearte
530 -- a labelled return point. That's why its interface is a little
531 -- different to cgAlgAlts
533 -- INVARIANT: the default binder is already bound
534 cgPrimAlts gc_flag alt_type scrutinee alts
535 = do { tagged_absCs <- forkAlts (map (cgPrimAlt gc_flag alt_type) alts)
536 ; let ((DEFAULT, deflt_absC) : others) = tagged_absCs -- There is always a default
537 alt_absCs = [(lit,rhs) | (LitAlt lit, rhs) <- others]
538 ; emitLitSwitch (CmmReg scrutinee) alt_absCs deflt_absC }
542 -> StgAlt -- The alternative
543 -> FCode (AltCon, CgStmts) -- Its compiled form
545 cgPrimAlt gc_flag alt_type (con, [], [], rhs)
546 = ASSERT( case con of { DEFAULT -> True; LitAlt _ -> True; other -> False } )
547 do { abs_c <- getCgStmts (maybeAltHeapCheck gc_flag alt_type (cgExpr rhs))
548 ; returnFC (con, abs_c) }
552 %************************************************************************
554 \subsection[CgCase-tidy]{Code for tidying up prior to an eval}
556 %************************************************************************
561 -> AltType -- PolyAlt, PrimAlt, AlgAlt, but *not* UbxTupAlt
562 -> Code -- Continuation
564 maybeAltHeapCheck NoGC _ code = code
565 maybeAltHeapCheck GCMayHappen alt_type code = altHeapCheck alt_type code
567 saveVolatileVarsAndRegs
568 :: StgLiveVars -- Vars which should be made safe
569 -> FCode (CmmStmts, -- Assignments to do the saves
570 EndOfBlockInfo, -- sequel for the alts
571 Maybe VirtualSpOffset) -- Slot for current cost centre
573 saveVolatileVarsAndRegs vars
574 = do { var_saves <- saveVolatileVars vars
575 ; (maybe_cc_slot, cc_save) <- saveCurrentCostCentre
576 ; eob_info <- getEndOfBlockInfo
577 ; returnFC (var_saves `plusStmts` cc_save,
582 saveVolatileVars :: StgLiveVars -- Vars which should be made safe
583 -> FCode CmmStmts -- Assignments to to the saves
585 saveVolatileVars vars
586 = do { stmts_s <- mapFCs save_it (varSetElems vars)
587 ; return (foldr plusStmts noStmts stmts_s) }
590 = do { v <- getCAddrModeIfVolatile var
592 Nothing -> return noStmts -- Non-volatile
593 Just vol_amode -> save_var var vol_amode -- Aha! It's volatile
596 save_var var vol_amode
597 = do { slot <- allocPrimStack (idCgRep var)
598 ; rebindToStack var slot
599 ; sp_rel <- getSpRelOffset slot
600 ; returnFC (oneStmt (CmmStore sp_rel vol_amode)) }
603 ---------------------------------------------------------------------------
605 When we save the current cost centre (which is done for lexical
606 scoping), we allocate a free stack location, and return (a)~the
607 virtual offset of the location, to pass on to the alternatives, and
608 (b)~the assignment to do the save (just as for @saveVolatileVars@).
611 saveCurrentCostCentre ::
612 FCode (Maybe VirtualSpOffset, -- Where we decide to store it
613 CmmStmts) -- Assignment to save it
615 saveCurrentCostCentre
616 | not opt_SccProfilingOn
617 = returnFC (Nothing, noStmts)
619 = do { slot <- allocPrimStack PtrArg
620 ; sp_rel <- getSpRelOffset slot
621 ; returnFC (Just slot,
622 oneStmt (CmmStore sp_rel curCCS)) }
624 -- Sometimes we don't free the slot containing the cost centre after restoring it
625 -- (see CgLetNoEscape.cgLetNoEscapeBody).
626 restoreCurrentCostCentre :: Maybe VirtualSpOffset -> Bool -> Code
627 restoreCurrentCostCentre Nothing _freeit = nopC
628 restoreCurrentCostCentre (Just slot) freeit
629 = do { sp_rel <- getSpRelOffset slot
630 ; whenC freeit (freeStackSlots [slot])
631 ; stmtC (CmmStore curCCSAddr (CmmLoad sp_rel wordRep)) }