[project @ 1996-01-08 20:28:12 by partain]
[ghc.git] / ghc / compiler / codeGen / CgCase.lhs
1 %
2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
3 %
4 %********************************************************
5 %*                                                      *
6 \section[CgCase]{Converting @StgCase@ expressions}
7 %*                                                      *
8 %********************************************************
9
10 \begin{code}
11 #include "HsVersions.h"
12
13 module CgCase (
14         cgCase,
15         saveVolatileVarsAndRegs,
16
17         -- and to make the interface self-sufficient...
18         StgExpr, Id, StgCaseAlternatives, CgState
19     ) where
20
21 IMPORT_Trace            -- ToDo: rm (debugging)
22 import Outputable
23 import Pretty
24
25 import StgSyn
26 import CgMonad
27 import AbsCSyn
28
29 import AbsPrel          ( PrimOp(..), primOpCanTriggerGC
30                           IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp)
31                           IF_ATTACK_PRAGMAS(COMMA pprPrimOp)
32                         )
33 import AbsUniType       ( kindFromType, getTyConDataCons,
34                           getUniDataSpecTyCon, getUniDataSpecTyCon_maybe,
35                           isEnumerationTyCon,
36                           UniType
37                         )
38 import CgBindery        -- all of it
39 import CgCon            ( buildDynCon, bindConArgs )
40 import CgExpr           ( cgExpr, getPrimOpArgAmodes )
41 import CgHeapery        ( heapCheck )
42 import CgRetConv        -- lots of stuff
43 import CgStackery       -- plenty
44 import CgTailCall       ( tailCallBusiness, performReturn )
45 import CgUsages         -- and even more
46 import CLabelInfo       -- bunches of things...
47 import ClosureInfo      {-( blackHoleClosureInfo, mkConLFInfo, mkLFArgument,
48                           layOutDynCon
49                         )-}
50 import CmdLineOpts      ( GlobalSwitch(..) )
51 import CostCentre       ( useCurrentCostCentre, CostCentre )
52 import BasicLit         ( kindOfBasicLit )
53 import Id               ( getDataConTag, getIdKind, fIRST_TAG, isDataCon,
54                           toplevelishId, getInstantiatedDataConSig,
55                           ConTag(..), DataCon(..)
56                         )
57 import Maybes           ( catMaybes, Maybe(..) )
58 import PrimKind         ( getKindSize, isFollowableKind, retKindSize, PrimKind(..) )
59 import UniqSet          -- ( uniqSetToList, UniqSet(..) )
60 import Util
61 \end{code}
62
63 \begin{code}
64 data GCFlag
65   = GCMayHappen -- The scrutinee may involve GC, so everything must be
66                 -- tidy before the code for the scrutinee.
67
68   | NoGC        -- The scrutinee is a primitive value, or a call to a
69                 -- primitive op which does no GC.  Hence the case can
70                 -- be done inline, without tidying up first.
71 \end{code}
72
73 It is quite interesting to decide whether to put a heap-check
74 at the start of each alternative.  Of course we certainly have
75 to do so if the case forces an evaluation, or if there is a primitive
76 op which can trigger GC.  
77
78 A more interesting situation is this:
79
80 \begin{verbatim}
81         !A!;
82         ...A...
83         case x# of
84           0#      -> !B!; ...B...
85           default -> !C!; ...C...
86 \end{verbatim}
87
88 where \tr{!x!} indicates a possible heap-check point. The heap checks
89 in the alternatives {\em can} be omitted, in which case the topmost
90 heapcheck will take their worst case into account.
91
92 In favour of omitting \tr{!B!}, \tr{!C!}:
93
94 \begin{itemize}
95 \item
96 {\em May} save a heap overflow test, 
97         if ...A... allocates anything.  The other advantage
98         of this is that we can use relative addressing
99         from a single Hp to get at all the closures so allocated.
100 \item
101  No need to save volatile vars etc across the case
102 \end{itemize}
103
104 Against:
105         
106 \begin{itemize}
107 \item
108    May do more allocation than reqd.  This sometimes bites us
109         badly.  For example, nfib (ha!)  allocates about 30\% more space if the
110         worst-casing is done, because many many calls to nfib are leaf calls
111         which don't need to allocate anything.
112
113         This never hurts us if there is only one alternative.
114 \end{itemize}
115
116
117 *** NOT YET DONE ***  The difficulty is that \tr{!B!}, \tr{!C!} need
118 to take account of what is live, and that includes all live volatile
119 variables, even if they also have stable analogues.  Furthermore, the
120 stack pointers must be lined up properly so that GC sees tidy stacks.
121 If these things are done, then the heap checks can be done at \tr{!B!} and
122 \tr{!C!} without a full save-volatile-vars sequence.
123
124 \begin{code}
125 cgCase  :: PlainStgExpr
126         -> PlainStgLiveVars
127         -> PlainStgLiveVars
128         -> Unique
129         -> PlainStgCaseAlternatives
130         -> Code
131 \end{code}
132
133 Several special cases for primitive operations.
134
135 ******* TO DO TO DO: fix what follows
136
137 Special case for
138
139         case (op x1 ... xn) of
140           y -> e
141
142 where the type of the case scrutinee is a multi-constuctor algebraic type.
143 Then we simply compile code for
144
145         let y = op x1 ... xn
146         in
147         e
148
149 In this case:
150
151         case (op x1 ... xn) of
152            C a b -> ...
153            y     -> e
154
155 where the type of the case scrutinee is a multi-constuctor algebraic type.
156 we just bomb out at the moment. It never happens in practice.
157
158 **** END OF TO DO TO DO
159
160 \begin{code}
161 cgCase scrut@(StgPrimApp op args _) live_in_whole_case live_in_alts uniq 
162        (StgAlgAlts _ alts (StgBindDefault id _ deflt_rhs))
163   = if not (null alts) then
164         panic "cgCase: case on PrimOp with default *and* alts\n"
165         -- For now, die if alts are non-empty
166     else
167 #if 0
168         pprTrace "cgCase:prim app returning alg data type: bad code!" (ppr PprDebug scrut) $
169         -- See above TO DO TO DO
170 #endif
171         cgExpr (StgLet (StgNonRec id scrut_rhs) deflt_rhs)
172   where
173     scrut_rhs       = StgRhsClosure useCurrentCostCentre stgArgOcc{-safe-} scrut_free_vars
174                                 Updatable [] scrut
175     scrut_free_vars = [ fv | StgVarAtom fv <- args, not (toplevelishId fv) ]
176                         -- Hack, hack
177 \end{code}
178
179
180 \begin{code}
181 cgCase (StgPrimApp op args _) live_in_whole_case live_in_alts uniq alts
182   | not (primOpCanTriggerGC op)
183   =
184         -- Get amodes for the arguments and results
185     getPrimOpArgAmodes op args                  `thenFC` \ arg_amodes -> 
186     let
187         result_amodes = getPrimAppResultAmodes uniq alts
188         liveness_mask = panic "cgCase: liveness of non-GC-ing primop touched\n"
189     in
190         -- Perform the operation
191     getVolatileRegs live_in_alts                        `thenFC` \ vol_regs ->
192
193     profCtrC SLIT("SET_ACTIVITY") [CLitLit SLIT("ACT_PRIM") IntKind]  `thenC`
194
195     absC (COpStmt result_amodes op
196                  arg_amodes -- note: no liveness arg
197                  liveness_mask vol_regs)                `thenC`
198
199     profCtrC SLIT("SET_ACTIVITY") [CLitLit SLIT("ACT_PRIM_STOP") IntKind]  `thenC`
200
201         -- Scrutinise the result
202     cgInlineAlts NoGC uniq alts
203
204   | otherwise   -- *Can* trigger GC
205   = getPrimOpArgAmodes op args          `thenFC` \ arg_amodes ->
206
207         -- Get amodes for the arguments and results, and assign to regs
208         -- (Can-trigger-gc primops guarantee to have their (nonRobust)
209         --  args in regs)
210     let
211         op_result_regs = assignPrimOpResultRegs op
212
213         op_result_amodes = map CReg op_result_regs
214
215         (op_arg_amodes, liveness_mask, arg_assts) 
216           = makePrimOpArgsRobust op arg_amodes
217
218         liveness_arg  = mkIntCLit liveness_mask
219     in
220         -- Tidy up in case GC happens...
221
222         -- Nota Bene the use of live_in_whole_case in nukeDeadBindings.
223         -- Reason: the arg_assts computed above may refer to some stack slots
224         -- which are not live in the alts.  So we mustn't use those slots
225         -- to save volatile vars in!
226     nukeDeadBindings live_in_whole_case `thenC`
227     saveVolatileVars live_in_alts       `thenFC` \ volatile_var_save_assts ->
228
229     getEndOfBlockInfo                   `thenFC` \ eob_info ->
230     forkEval eob_info nopC 
231              (getAbsC (cgInlineAlts GCMayHappen uniq alts) `thenFC` \ abs_c ->
232               absC (CRetUnVector vtbl_label (CLabelledCode return_label abs_c))
233                                         `thenC`
234               returnFC (CaseAlts (CUnVecLbl return_label vtbl_label) 
235                                  Nothing{-no semi-tagging-}))
236             `thenFC` \ new_eob_info ->
237
238         -- Record the continuation info
239     setEndOfBlockInfo new_eob_info (
240
241         -- Now "return" to the inline alternatives; this will get 
242         -- compiled to a fall-through.
243     let
244         simultaneous_assts = arg_assts `mkAbsCStmts` volatile_var_save_assts
245         
246         -- do_op_and_continue will be passed an amode for the continuation
247         do_op_and_continue sequel
248           = profCtrC SLIT("SET_ACTIVITY") [CLitLit SLIT("ACT_PRIM") IntKind]  `thenC`
249
250             absC (COpStmt op_result_amodes
251                           op
252                           (pin_liveness op liveness_arg op_arg_amodes)
253                           liveness_mask
254                           [{-no vol_regs-}])
255                                         `thenC`
256
257             profCtrC SLIT("SET_ACTIVITY") [CLitLit SLIT("ACT_PRIM_STOP") IntKind]  `thenC`
258
259             sequelToAmode sequel        `thenFC` \ dest_amode ->
260             absC (CReturn dest_amode DirectReturn)
261
262                 -- Note: we CJump even for algebraic data types,
263                 -- because cgInlineAlts always generates code, never a
264                 -- vector.
265     in
266     performReturn simultaneous_assts do_op_and_continue live_in_alts
267     )
268   where
269     -- for all PrimOps except ccalls, we pin the liveness info
270     -- on as the first "argument"
271     -- ToDo: un-duplicate?
272
273     pin_liveness (CCallOp _ _ _ _ _) _ args = args
274     pin_liveness other_op liveness_arg args
275       = liveness_arg :args
276
277     vtbl_label = mkVecTblLabel uniq
278     return_label = mkReturnPtLabel uniq
279
280 \end{code}
281
282 Another special case: scrutinising a primitive-typed variable.  No
283 evaluation required.  We don't save volatile variables, nor do we do a
284 heap-check in the alternatives.  Instead, the heap usage of the
285 alternatives is worst-cased and passed upstream.  This can result in
286 allocating more heap than strictly necessary, but it will sometimes
287 eliminate a heap check altogether.
288
289 \begin{code}
290 cgCase (StgApp v [] _) live_in_whole_case live_in_alts uniq (StgPrimAlts ty alts deflt)
291   = getAtomAmode v              `thenFC` \ amode ->
292     cgPrimAltsGivenScrutinee NoGC amode alts deflt
293 \end{code}
294
295 Special case: scrutinising a non-primitive variable.
296 This can be done a little better than the general case, because
297 we can reuse/trim the stack slot holding the variable (if it is in one).
298
299 \begin{code}
300 cgCase (StgApp (StgVarAtom fun) args _ {-lvs must be same as live_in_alts-}) 
301         live_in_whole_case live_in_alts uniq alts@(StgAlgAlts _ _ _)
302   =
303     getCAddrModeAndInfo fun             `thenFC` \ (fun_amode, lf_info) ->
304     getAtomAmodes args                  `thenFC` \ arg_amodes ->
305
306         -- Squish the environment
307     nukeDeadBindings live_in_alts       `thenC`
308     saveVolatileVarsAndRegs live_in_alts 
309                         `thenFC` \ (save_assts, alts_eob_info, maybe_cc_slot) ->
310
311     forkEval alts_eob_info
312              nopC (cgEvalAlts maybe_cc_slot uniq alts) `thenFC` \ scrut_eob_info ->
313     setEndOfBlockInfo scrut_eob_info  (
314       tailCallBusiness fun fun_amode lf_info arg_amodes live_in_alts save_assts
315     )
316
317 \end{code}
318
319 Finally, here is the general case.
320
321 \begin{code}
322 cgCase expr live_in_whole_case live_in_alts uniq alts
323   =     -- Figure out what volatile variables to save
324     nukeDeadBindings live_in_whole_case `thenC`
325     saveVolatileVarsAndRegs live_in_alts
326                         `thenFC` \ (save_assts, alts_eob_info, maybe_cc_slot) ->
327
328         -- Save those variables right now!      
329     absC save_assts                     `thenC`
330
331     forkEval alts_eob_info 
332         (nukeDeadBindings live_in_alts)
333         (cgEvalAlts maybe_cc_slot uniq alts) `thenFC` \ scrut_eob_info ->
334
335     setEndOfBlockInfo scrut_eob_info (cgExpr expr)
336 \end{code}
337
338 %************************************************************************
339 %*                                                                      *
340 \subsection[CgCase-primops]{Primitive applications}
341 %*                                                                      *
342 %************************************************************************
343
344 Get result amodes for a primitive operation, in the case wher GC can't happen.
345 The  amodes are returned in canonical order, ready for the prim-op!
346
347         Alg case: temporaries named as in the alternatives,
348                   plus (CTemp u) for the tag (if needed)
349         Prim case: (CTemp u)
350
351 This is all disgusting, because these amodes must be consistent with those
352 invented by CgAlgAlts.
353
354 \begin{code}
355 getPrimAppResultAmodes
356         :: Unique
357         -> PlainStgCaseAlternatives
358         -> [CAddrMode]
359 \end{code}
360
361 \begin{code}
362 -- If there's an StgBindDefault which does use the bound
363 -- variable, then we can only handle it if the type involved is
364 -- an enumeration type.   That's important in the case
365 -- of comparisions:
366 --
367 --      case x ># y of
368 --        r -> f r
369 --
370 -- The only reason for the restriction to *enumeration* types is our
371 -- inability to invent suitable temporaries to hold the results;
372 -- Elaborating the CTemp addr mode to have a second uniq field
373 -- (which would simply count from 1) would solve the problem.
374 -- Anyway, cgInlineAlts is now capable of handling all cases;
375 -- it's only this function which is being wimpish.
376
377 getPrimAppResultAmodes uniq (StgAlgAlts ty alts (StgBindDefault _ True {- used -} _))
378   | isEnumerationTyCon spec_tycon = [tag_amode]
379   | otherwise                     = panic "getPrimAppResultAmodes: non-enumeration algebraic alternatives with default"
380   where
381     -- A temporary variable to hold the tag; this is unaffected by GC because
382     -- the heap-checks in the branches occur after the switch
383     tag_amode     = CTemp uniq IntKind
384     (spec_tycon, _, _) = getUniDataSpecTyCon ty
385
386 getPrimAppResultAmodes uniq (StgAlgAlts ty alts other_default)
387         -- Default is either StgNoDefault or StgBindDefault with unused binder
388   = case alts of
389         [_]     -> arg_amodes                   -- No need for a tag
390         other   -> tag_amode : arg_amodes
391   where
392     -- A temporary variable to hold the tag; this is unaffected by GC because
393     -- the heap-checks in the branches occur after the switch
394     tag_amode = CTemp uniq IntKind
395
396     -- Sort alternatives into canonical order; there must be a complete
397     -- set because there's no default case.
398     sorted_alts = sortLt lt alts
399     (con1,_,_,_) `lt` (con2,_,_,_) = getDataConTag con1 < getDataConTag con2
400
401     arg_amodes :: [CAddrMode]
402
403     -- Turn them into amodes
404     arg_amodes = concat (map mk_amodes sorted_alts)
405     mk_amodes (con, args, use_mask, rhs)
406       = [ CTemp (getTheUnique arg) (getIdKind arg) | arg <- args ]
407 \end{code}
408
409 The situation is simpler for primitive
410 results, because there is only one!
411
412 \begin{code}
413 getPrimAppResultAmodes uniq (StgPrimAlts ty _ _)
414   = [CTemp uniq kind]
415   where
416     kind = kindFromType ty
417 \end{code}
418
419
420 %************************************************************************
421 %*                                                                      *
422 \subsection[CgCase-alts]{Alternatives}
423 %*                                                                      *
424 %************************************************************************
425
426 @cgEvalAlts@ returns an addressing mode for a continuation for the
427 alternatives of a @case@, used in a context when there
428 is some evaluation to be done.
429
430 \begin{code}
431 cgEvalAlts :: Maybe VirtualSpBOffset    -- Offset of cost-centre to be restored, if any
432            -> Unique
433            -> PlainStgCaseAlternatives
434            -> FCode Sequel              -- Any addr modes inside are guaranteed to be a label
435                                         -- so that we can duplicate it without risk of
436                                         -- duplicating code
437
438 cgEvalAlts cc_slot uniq (StgAlgAlts ty alts deflt)
439   =     -- Generate the instruction to restore cost centre, if any
440     restoreCurrentCostCentre cc_slot    `thenFC` \ cc_restore ->
441
442         -- Generate sequel info for use downstream
443         -- At the moment, we only do it if the type is vector-returnable.
444         -- Reason: if not, then it costs extra to label the
445         -- alternatives, because we'd get return code like:
446         --
447         --      switch TagReg { 0 : JMP(alt_1); 1 : JMP(alt_2) ..etc }
448         --
449         -- which is worse than having the alt code in the switch statement
450
451     let
452         (spec_tycon, _, _) = getUniDataSpecTyCon ty
453
454         use_labelled_alts 
455           = case ctrlReturnConvAlg spec_tycon of
456               VectoredReturn _ -> True
457               _                -> False
458
459         semi_tagged_stuff
460           = if not use_labelled_alts then
461                 Nothing -- no semi-tagging info
462             else
463                 cgSemiTaggedAlts uniq alts deflt -- Just <something>
464     in
465     cgAlgAlts GCMayHappen uniq cc_restore use_labelled_alts ty alts deflt
466                                         `thenFC` \ (tagged_alt_absCs, deflt_absC) ->
467
468     mkReturnVector uniq ty tagged_alt_absCs deflt_absC `thenFC` \ return_vec ->
469
470     returnFC (CaseAlts return_vec semi_tagged_stuff)
471
472 cgEvalAlts cc_slot uniq (StgPrimAlts ty alts deflt)
473   =     -- Generate the instruction to restore cost centre, if any
474     restoreCurrentCostCentre cc_slot                     `thenFC` \ cc_restore ->
475
476         -- Generate the switch
477     getAbsC (cgPrimAlts GCMayHappen uniq ty alts deflt)  `thenFC` \ abs_c ->
478
479         -- Generate the labelled block, starting with restore-cost-centre
480     absC (CRetUnVector vtbl_label 
481          (CLabelledCode return_label (cc_restore `mkAbsCStmts` abs_c)))
482                                                          `thenC`
483         -- Return an amode for the block
484     returnFC (CaseAlts (CUnVecLbl return_label vtbl_label) Nothing{-no semi-tagging-})
485   where
486     vtbl_label = mkVecTblLabel uniq
487     return_label = mkReturnPtLabel uniq
488 \end{code}
489
490
491 \begin{code}
492 cgInlineAlts :: GCFlag -> Unique
493              -> PlainStgCaseAlternatives
494              -> Code
495 \end{code}
496
497 First case: algebraic case, exactly one alternative, no default.
498 In this case the primitive op will not have set a temporary to the
499 tag, so we shouldn't generate a switch statment.  Instead we just
500 do the right thing.
501
502 \begin{code}
503 cgInlineAlts gc_flag uniq (StgAlgAlts ty [alt@(con,args,use_mask,rhs)] StgNoDefault)
504   = cgAlgAltRhs gc_flag con args use_mask rhs
505 \end{code}
506
507 Second case: algebraic case, several alternatives.
508 Tag is held in a temporary.
509
510 \begin{code}
511 cgInlineAlts gc_flag uniq (StgAlgAlts ty alts deflt)
512   = cgAlgAlts gc_flag uniq AbsCNop{-restore_cc-} False{-no semi-tagging-}
513                 ty alts deflt   `thenFC` \ (tagged_alts, deflt_c) ->
514
515         -- Do the switch
516     absC (mkAlgAltsCSwitch tag_amode tagged_alts deflt_c)
517  where
518     -- A temporary variable to hold the tag; this is unaffected by GC because
519     -- the heap-checks in the branches occur after the switch
520     tag_amode = CTemp uniq IntKind
521 \end{code}
522
523 =========== OLD: we *can* now handle this case ================
524
525 Next, a case we can't deal with: an algebraic case with no evaluation
526 required (so it is in-line), and a default case as well.  In this case
527 we require all the alternatives written out, so that we can invent
528 suitable binders to pass to the PrimOp. A default case defeats this.
529 Could be fixed, but probably isn't worth it.
530
531 \begin{code}
532 {- ============= OLD
533 cgInlineAlts gc_flag uniq (StgAlgAlts ty alts other_default)
534   = panic "cgInlineAlts: alg alts with default"
535 ================= END OF OLD -}
536 \end{code}
537
538 Third (real) case: primitive result type.
539
540 \begin{code}
541 cgInlineAlts gc_flag uniq (StgPrimAlts ty alts deflt)
542   = cgPrimAlts gc_flag uniq ty alts deflt
543 \end{code}
544
545
546 %************************************************************************
547 %*                                                                      *
548 \subsection[CgCase-alg-alts]{Algebraic alternatives}
549 %*                                                                      *
550 %************************************************************************
551
552 In @cgAlgAlts@, none of the binders in the alternatives are
553 assumed to be yet bound.
554
555 \begin{code}
556 cgAlgAlts :: GCFlag
557           -> Unique
558           -> AbstractC                          -- Restore-cost-centre instruction
559           -> Bool                               -- True <=> branches must be labelled
560           -> UniType                            -- From the case statement
561           -> [(Id, [Id], [Bool], PlainStgExpr)] -- The alternatives
562           -> PlainStgCaseDefault                -- The default
563           -> FCode ([(ConTag, AbstractC)],      -- The branches
564                     AbstractC                   -- The default case
565              )
566 \end{code}
567
568 The case with a default which has a binder is different.  We need to
569 pick all the constructors which aren't handled explicitly by an
570 alternative, and which return their results in registers, allocate
571 them explicitly in the heap, and jump to a join point for the default
572 case.
573
574 OLD:  All of this only works if a heap-check is required anyway, because
575 otherwise it isn't safe to allocate. 
576
577 NEW (July 94): now false!  It should work regardless of gc_flag,
578 because of the extra_branches argument now added to forkAlts.
579
580 We put a heap-check at the join point, for the benefit of constructors
581 which don't need to do allocation. This means that ones which do need
582 to allocate may end up doing two heap-checks; but that's just too bad.
583 (We'd need two join labels otherwise.  ToDo.)
584
585 It's all pretty turgid anyway.
586
587 \begin{code}
588 cgAlgAlts gc_flag uniq restore_cc semi_tagging
589         ty alts deflt@(StgBindDefault binder True{-used-} _)
590   = forkAlts (map (cgAlgAlt gc_flag uniq restore_cc semi_tagging) alts)
591              extra_branches
592              (cgAlgDefault  gc_flag uniq restore_cc must_label_default deflt)
593   where
594     extra_branches :: [FCode (ConTag, AbstractC)]
595     extra_branches = catMaybes (map mk_extra_branch default_cons)
596
597     must_label_default = semi_tagging || not (null extra_branches)
598
599     default_join_lbl = mkDefaultLabel uniq
600     jump_instruction = CJump (CLbl default_join_lbl CodePtrKind)
601
602     (spec_tycon, _, spec_cons)
603       = -- trace ("cgCase:tycon:"++(ppShow 80 (ppAboves [
604         --      ppr PprDebug uniq,
605         --      ppr PprDebug ty,
606         --      ppr PprShowAll binder
607         --      ]))) (
608         getUniDataSpecTyCon ty
609         -- )
610
611     alt_cons = [ con | (con,_,_,_) <- alts ]
612
613     default_cons  = [ spec_con | spec_con <- spec_cons, -- In this type
614                                  spec_con `not_elem` alt_cons ] -- Not handled explicitly
615         where
616           not_elem = isn'tIn "cgAlgAlts"
617
618     -- (mk_extra_branch con) returns the a maybe for the extra branch for con.
619     -- The "maybe" is because con may return in heap, in which case there is
620     -- nothing to do. Otherwise, we have a special case for a nullary constructor,
621     -- but in the general case we do an allocation and heap-check.
622
623     mk_extra_branch :: DataCon -> (Maybe (FCode (ConTag, AbstractC)))
624
625     mk_extra_branch con
626       = ASSERT(isDataCon con)
627         case dataReturnConvAlg con of
628           ReturnInHeap    -> Nothing
629           ReturnInRegs rs -> Just (getAbsC (alloc_code rs) `thenFC` \ abs_c ->
630                                    returnFC (tag, abs_c)
631                                   )
632       where
633         lf_info         = mkConLFInfo con
634         tag             = getDataConTag con
635         closure_lbl     = mkClosureLabel con
636
637         -- alloc_code generates code to allocate constructor con, whose args are
638         -- in the arguments to alloc_code, assigning the result to Node.
639         alloc_code :: [MagicId] -> Code
640
641         alloc_code regs
642           = possibleHeapCheck gc_flag regs False (
643                 buildDynCon binder useCurrentCostCentre con
644                                 (map CReg regs) (all zero_size regs)
645                                                 `thenFC` \ idinfo ->
646                 idInfoToAmode PtrKind idinfo    `thenFC` \ amode ->
647
648                 absC (CAssign (CReg node) amode) `thenC`
649                 absC jump_instruction
650             )
651           where
652             zero_size reg = getKindSize (kindFromMagicId reg) == 0
653 \end{code}
654
655 Now comes the general case
656
657 \begin{code}
658 cgAlgAlts gc_flag uniq restore_cc must_label_branches ty alts deflt 
659         {- The deflt is either StgNoDefault or a BindDefault which doesn't use the binder -}
660   = forkAlts (map (cgAlgAlt gc_flag uniq restore_cc must_label_branches) alts)
661              [{- No "extra branches" -}]
662              (cgAlgDefault gc_flag uniq restore_cc must_label_branches deflt)
663 \end{code}
664
665 \begin{code}
666 cgAlgDefault :: GCFlag
667              -> Unique -> AbstractC -> Bool -- turgid state...
668              -> PlainStgCaseDefault         -- input
669              -> FCode AbstractC             -- output
670
671 cgAlgDefault gc_flag uniq restore_cc must_label_branch
672              StgNoDefault
673   = returnFC AbsCNop
674
675 cgAlgDefault gc_flag uniq restore_cc must_label_branch
676              (StgBindDefault _ False{-binder not used-} rhs)
677
678   = getAbsC (absC restore_cc `thenC`
679              possibleHeapCheck gc_flag [] False (cgExpr rhs)) `thenFC` \ abs_c ->
680     let
681         final_abs_c | must_label_branch = CJump (CLabelledCode lbl abs_c)
682                     | otherwise         = abs_c
683     in
684     returnFC final_abs_c
685   where
686     lbl = mkDefaultLabel uniq
687
688
689 cgAlgDefault gc_flag uniq restore_cc must_label_branch
690              (StgBindDefault binder True{-binder used-} rhs)
691
692   =     -- We have arranged that Node points to the thing, even
693         -- even if we return in registers
694     bindNewToReg binder node mkLFArgument `thenC`
695     getAbsC (absC restore_cc `thenC`
696              possibleHeapCheck gc_flag [node] False (cgExpr rhs)
697         -- Node is live, but doesn't need to point at the thing itself;
698         -- it's ok for Node to point to an indirection or FETCH_ME
699         -- Hence no need to re-enter Node.
700     )                                   `thenFC` \ abs_c ->
701
702     let
703         final_abs_c | must_label_branch = CJump (CLabelledCode lbl abs_c)
704                     | otherwise         = abs_c
705     in
706     returnFC final_abs_c
707   where
708     lbl = mkDefaultLabel uniq
709
710
711 cgAlgAlt :: GCFlag
712          -> Unique -> AbstractC -> Bool         -- turgid state
713          -> (Id, [Id], [Bool], PlainStgExpr)
714          -> FCode (ConTag, AbstractC)
715
716 cgAlgAlt gc_flag uniq restore_cc must_label_branch (con, args, use_mask, rhs)
717   = getAbsC (absC restore_cc `thenC`
718              cgAlgAltRhs gc_flag con args use_mask rhs) `thenFC` \ abs_c -> 
719     let
720         final_abs_c | must_label_branch = CJump (CLabelledCode lbl abs_c)
721                     | otherwise         = abs_c
722     in
723     returnFC (tag, final_abs_c)
724   where
725     tag = getDataConTag con
726     lbl = mkAltLabel uniq tag
727
728 cgAlgAltRhs :: GCFlag -> Id -> [Id] -> [Bool] -> PlainStgExpr -> Code
729
730 cgAlgAltRhs gc_flag con args use_mask rhs
731   = let
732       (live_regs, node_reqd)
733         = case (dataReturnConvAlg con) of
734             ReturnInHeap      -> ([],                                             True)
735             ReturnInRegs regs -> ([reg | (reg,True) <- regs `zipEqual` use_mask], False)
736                                 -- Pick the live registers using the use_mask
737                                 -- Doing so is IMPORTANT, because with semi-tagging
738                                 -- enabled only the live registers will have valid
739                                 -- pointers in them.
740     in
741     possibleHeapCheck gc_flag live_regs node_reqd (
742     (case gc_flag of
743         NoGC        -> mapFCs bindNewToTemp args `thenFC` \ _ ->
744                        nopC
745         GCMayHappen -> bindConArgs con args
746     )   `thenC`
747     cgExpr rhs 
748     )
749 \end{code}
750
751 %************************************************************************
752 %*                                                                      *
753 \subsection[CgCase-semi-tagged-alts]{The code to deal with sem-tagging}
754 %*                                                                      *
755 %************************************************************************
756
757 Turgid-but-non-monadic code to conjure up the required info from
758 algebraic case alternatives for semi-tagging.
759
760 \begin{code}
761 cgSemiTaggedAlts :: Unique
762                  -> [(Id, [Id], [Bool], PlainStgExpr)]
763                  -> StgCaseDefault Id Id
764                  -> SemiTaggingStuff
765
766 cgSemiTaggedAlts uniq alts deflt
767   = Just (map st_alt alts, st_deflt deflt)
768   where
769     st_deflt StgNoDefault = Nothing
770
771     st_deflt (StgBindDefault binder binder_used _)
772       = Just (if binder_used then Just binder else Nothing,
773               (CCallProfCtrMacro SLIT("RET_SEMI_BY_DEFAULT") [], -- ToDo: monadise?
774                mkDefaultLabel uniq)
775              )
776
777     st_alt (con, args, use_mask, _)
778       = case (dataReturnConvAlg con) of
779
780           ReturnInHeap ->
781             -- Ha!  Nothing to do; Node already points to the thing
782             (con_tag,
783              (CCallProfCtrMacro SLIT("RET_SEMI_IN_HEAP") [], -- ToDo: monadise?
784              join_label)
785             )
786
787           ReturnInRegs regs ->
788             -- We have to load the live registers from the constructor
789             -- pointed to by Node.
790             let
791                 (_, regs_w_offsets) = layOutDynCon con kindFromMagicId regs
792
793                 used_regs = selectByMask use_mask regs
794
795                 used_regs_w_offsets = [ ro | ro@(reg,offset) <- regs_w_offsets, 
796                                              reg `is_elem` used_regs]
797
798                 is_elem = isIn "cgSemiTaggedAlts"
799             in
800             (con_tag,
801              (mkAbstractCs [
802                 CCallProfCtrMacro SLIT("RET_SEMI_IN_REGS") [], -- ToDo: macroise?
803                 CSimultaneous (mkAbstractCs (map move_to_reg used_regs_w_offsets))],
804               join_label))
805       where
806         con_tag     = getDataConTag con
807         join_label  = mkAltLabel uniq con_tag
808
809     move_to_reg :: (MagicId, VirtualHeapOffset {-from Node-}) -> AbstractC
810     move_to_reg (reg, offset)
811       = CAssign (CReg reg) (CVal (NodeRel offset) (kindFromMagicId reg))
812
813 \end{code}
814
815 %************************************************************************
816 %*                                                                      *
817 \subsection[CgCase-prim-alts]{Primitive alternatives}
818 %*                                                                      *
819 %************************************************************************
820
821 @cgPrimAlts@ generates a suitable @CSwitch@ for dealing with the
822 alternatives of a primitive @case@, given an addressing mode for the
823 thing to scrutinise.  It also keeps track of the maximum stack depth
824 encountered down any branch.
825
826 As usual, no binders in the alternatives are yet bound.
827
828 \begin{code}
829 cgPrimAlts :: GCFlag
830            -> Unique
831            -> UniType   
832            -> [(BasicLit, PlainStgExpr)]        -- Alternatives
833            -> PlainStgCaseDefault               -- Default
834            -> Code
835
836 cgPrimAlts gc_flag uniq ty alts deflt
837   = cgPrimAltsGivenScrutinee gc_flag scrutinee alts deflt
838  where
839     -- A temporary variable, or standard register, to hold the result
840     scrutinee = case gc_flag of
841                      NoGC        -> CTemp uniq kind
842                      GCMayHappen -> CReg (dataReturnConvPrim kind)
843
844     kind = kindFromType ty
845
846
847 cgPrimAltsGivenScrutinee gc_flag scrutinee alts deflt
848   = forkAlts (map (cgPrimAlt gc_flag) alts)
849              [{- No "extra branches" -}]
850              (cgPrimDefault gc_flag scrutinee deflt) `thenFC` \ (alt_absCs, deflt_absC) ->
851     absC (CSwitch scrutinee alt_absCs deflt_absC)
852           -- CSwitch does sensible things with one or zero alternatives
853
854
855 cgPrimAlt :: GCFlag
856           -> (BasicLit, PlainStgExpr)    -- The alternative
857           -> FCode (BasicLit, AbstractC) -- Its compiled form
858
859 cgPrimAlt gc_flag (lit, rhs)
860   = getAbsC rhs_code     `thenFC` \ absC ->
861     returnFC (lit,absC)
862   where
863     rhs_code = possibleHeapCheck gc_flag [] False (cgExpr rhs )
864
865 cgPrimDefault :: GCFlag
866               -> CAddrMode              -- Scrutinee
867               -> PlainStgCaseDefault
868               -> FCode AbstractC
869
870 cgPrimDefault gc_flag scrutinee StgNoDefault
871   = panic "cgPrimDefault: No default in prim case"
872
873 cgPrimDefault gc_flag scrutinee (StgBindDefault _ False{-binder not used-} rhs)
874   = getAbsC (possibleHeapCheck gc_flag [] False (cgExpr rhs ))
875
876 cgPrimDefault gc_flag scrutinee (StgBindDefault binder True{-used-} rhs)
877   = getAbsC (possibleHeapCheck gc_flag regs False rhs_code)
878   where
879     regs = if isFollowableKind (getAmodeKind scrutinee) then
880               [node] else []
881
882     rhs_code = bindNewPrimToAmode binder scrutinee `thenC`
883                cgExpr rhs
884 \end{code}
885
886
887 %************************************************************************
888 %*                                                                      *
889 \subsection[CgCase-tidy]{Code for tidying up prior to an eval}
890 %*                                                                      *
891 %************************************************************************
892
893 \begin{code}
894 saveVolatileVarsAndRegs
895     :: PlainStgLiveVars               -- Vars which should be made safe
896     -> FCode (AbstractC,              -- Assignments to do the saves
897        EndOfBlockInfo,                -- New sequel, recording where the return
898                                       -- address now is
899        Maybe VirtualSpBOffset)        -- Slot for current cost centre
900
901
902 saveVolatileVarsAndRegs vars
903   = saveVolatileVars vars     `thenFC` \ var_saves ->
904     saveCurrentCostCentre     `thenFC` \ (maybe_cc_slot, cc_save) ->
905     saveReturnAddress         `thenFC` \ (new_eob_info, ret_save) ->
906     returnFC (mkAbstractCs [var_saves, cc_save, ret_save],
907               new_eob_info,
908               maybe_cc_slot)
909
910
911 saveVolatileVars :: PlainStgLiveVars    -- Vars which should be made safe
912                  -> FCode AbstractC     -- Assignments to to the saves
913
914 saveVolatileVars vars
915   = save_em (uniqSetToList vars)
916   where
917     save_em [] = returnFC AbsCNop
918
919     save_em (var:vars)
920       = getCAddrModeIfVolatile var `thenFC` \ v ->
921         case v of
922             Nothing         -> save_em vars -- Non-volatile, so carry on
923                                
924
925             Just vol_amode  ->  -- Aha! It's volatile
926                                save_var var vol_amode   `thenFC` \ abs_c ->
927                                save_em vars             `thenFC` \ abs_cs ->
928                                returnFC (abs_c `mkAbsCStmts` abs_cs)
929
930     save_var var vol_amode
931       | isFollowableKind kind
932       = allocAStack                     `thenFC` \ a_slot ->
933         rebindToAStack var a_slot       `thenC`
934         getSpARelOffset a_slot          `thenFC` \ spa_rel ->
935         returnFC (CAssign (CVal spa_rel kind) vol_amode)
936       | otherwise
937       = allocBStack (getKindSize kind)  `thenFC` \ b_slot ->
938         rebindToBStack var b_slot       `thenC`
939         getSpBRelOffset b_slot          `thenFC` \ spb_rel ->
940         returnFC (CAssign (CVal spb_rel kind) vol_amode)
941       where
942         kind = getAmodeKind vol_amode
943
944 saveReturnAddress :: FCode (EndOfBlockInfo, AbstractC)
945 saveReturnAddress 
946   = getEndOfBlockInfo                `thenFC` \ eob_info@(EndOfBlockInfo vA vB sequel) ->
947
948       -- See if it is volatile
949     case sequel of
950       InRetReg ->     -- Yes, it's volatile
951                    allocBStack retKindSize    `thenFC` \ b_slot ->
952                    getSpBRelOffset b_slot      `thenFC` \ spb_rel ->
953
954                    returnFC (EndOfBlockInfo vA vB (OnStack b_slot),
955                              CAssign (CVal spb_rel RetKind) (CReg RetReg))
956
957       UpdateCode _ ->   -- It's non-volatile all right, but we still need
958                         -- to allocate a B-stack slot for it, *solely* to make
959                         -- sure that update frames for different values do not
960                         -- appear adjacent on the B stack. This makes sure
961                         -- that B-stack squeezing works ok.
962                         -- See note below
963                    allocBStack retKindSize    `thenFC` \ b_slot ->
964                    returnFC (eob_info, AbsCNop)
965
966       other ->           -- No, it's non-volatile, so do nothing
967                    returnFC (eob_info, AbsCNop)
968 \end{code}
969
970 Note about B-stack squeezing.  Consider the following:`
971
972         y = [...] \u [] -> ...
973         x = [y]   \u [] -> case y of (a,b) -> a
974
975 The code for x will push an update frame, and then enter y.  The code
976 for y will push another update frame.  If the B-stack-squeezer then
977 wakes up, it will see two update frames right on top of each other,
978 and will combine them.  This is WRONG, of course, because x's value is
979 not the same as y's.
980
981 The fix implemented above makes sure that we allocate an (unused)
982 B-stack slot before entering y.  You can think of this as holding the
983 saved value of RetAddr, which (after pushing x's update frame will be
984 some update code ptr).  The compiler is clever enough to load the
985 static update code ptr into RetAddr before entering ~a~, but the slot
986 is still there to separate the update frames.
987
988 When we save the current cost centre (which is done for lexical
989 scoping), we allocate a free B-stack location, and return (a)~the
990 virtual offset of the location, to pass on to the alternatives, and
991 (b)~the assignment to do the save (just as for @saveVolatileVars@).
992
993 \begin{code}
994 saveCurrentCostCentre :: 
995         FCode (Maybe VirtualSpBOffset,  -- Where we decide to store it
996                                         --   Nothing if not lexical CCs
997                AbstractC)               -- Assignment to save it
998                                         --   AbsCNop if not lexical CCs
999
1000 saveCurrentCostCentre
1001   = isSwitchSetC SccProfilingOn         `thenFC` \ doing_profiling ->
1002     if not doing_profiling then
1003         returnFC (Nothing, AbsCNop)
1004     else
1005         allocBStack (getKindSize CostCentreKind) `thenFC` \ b_slot ->
1006         getSpBRelOffset b_slot                   `thenFC` \ spb_rel ->
1007         returnFC (Just b_slot,
1008                   CAssign (CVal spb_rel CostCentreKind) (CReg CurCostCentre))
1009
1010 restoreCurrentCostCentre :: Maybe VirtualSpBOffset -> FCode AbstractC
1011
1012 restoreCurrentCostCentre Nothing 
1013  = returnFC AbsCNop
1014 restoreCurrentCostCentre (Just b_slot) 
1015  = getSpBRelOffset b_slot                        `thenFC` \ spb_rel ->
1016    freeBStkSlot b_slot                           `thenC`
1017    returnFC (CCallProfCCMacro SLIT("RESTORE_CCC") [CVal spb_rel CostCentreKind])
1018     -- we use the RESTORE_CCC macro, rather than just
1019     -- assigning into CurCostCentre, in case RESTORE_CCC
1020     -- has some sanity-checking in it.
1021 \end{code}
1022
1023
1024 %************************************************************************
1025 %*                                                                      *
1026 \subsection[CgCase-return-vec]{Building a return vector}
1027 %*                                                                      *
1028 %************************************************************************
1029
1030 Build a return vector, and return a suitable label addressing
1031 mode for it.
1032
1033 \begin{code}
1034 mkReturnVector :: Unique
1035                -> UniType
1036                -> [(ConTag, AbstractC)] -- Branch codes
1037                -> AbstractC             -- Default case
1038                -> FCode CAddrMode
1039
1040 mkReturnVector uniq ty tagged_alt_absCs deflt_absC
1041   = let
1042      (return_vec_amode, vtbl_body) = case (ctrlReturnConvAlg spec_tycon) of {
1043
1044       UnvectoredReturn _ ->
1045         (CUnVecLbl ret_label vtbl_label,
1046          absC (CRetUnVector vtbl_label
1047                             (CLabelledCode ret_label
1048                                            (mkAlgAltsCSwitch (CReg TagReg) 
1049                                                              tagged_alt_absCs 
1050                                                              deflt_absC))));
1051       VectoredReturn table_size ->
1052         (CLbl vtbl_label DataPtrKind,
1053          absC (CRetVector vtbl_label
1054                         -- must restore cc before each alt, if required
1055                           (map mk_vector_entry [fIRST_TAG .. (table_size+fIRST_TAG-1)])
1056                           deflt_absC))
1057
1058 -- Leave nops and comments in for now; they are eliminated
1059 -- lazily as it's printed.
1060 --                        (case (nonemptyAbsC deflt_absC) of
1061 --                              Nothing  -> AbsCNop
1062 --                              Just def -> def)
1063
1064     } in
1065     vtbl_body                                               `thenC`
1066     returnFC return_vec_amode
1067     -- )
1068   where
1069
1070     (spec_tycon,_,_) = case (getUniDataSpecTyCon_maybe ty) of -- *must* be a real "data" type constructor
1071               Just xx -> xx
1072               Nothing -> error ("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: "++(ppShow 80 (ppr PprDebug ty)))
1073
1074     vtbl_label = mkVecTblLabel uniq
1075     ret_label = mkReturnPtLabel uniq
1076
1077     mk_vector_entry :: ConTag -> Maybe CAddrMode
1078     mk_vector_entry tag
1079       = case [ absC | (t, absC) <- tagged_alt_absCs, t == tag ] of
1080              []     -> Nothing
1081              [absC] -> Just (CCode absC)
1082              _      -> panic "mkReturnVector: too many"
1083 \end{code}
1084
1085 %************************************************************************
1086 %*                                                                      *
1087 \subsection[CgCase-utils]{Utilities for handling case expressions}
1088 %*                                                                      *
1089 %************************************************************************
1090
1091 @possibleHeapCheck@ tests a flag passed in to decide whether to
1092 do a heap check or not.
1093
1094 \begin{code}
1095 possibleHeapCheck :: GCFlag -> [MagicId] -> Bool -> Code -> Code
1096
1097 possibleHeapCheck GCMayHappen regs node_reqd code = heapCheck regs node_reqd code
1098 possibleHeapCheck NoGC        _    _         code = code
1099 \end{code}
1100
1101 Select a restricted set of registers based on a usage mask.
1102
1103 \begin{code}
1104 selectByMask []         []         = []
1105 selectByMask (True:ms)  (x:xs) = x : selectByMask ms xs
1106 selectByMask (False:ms) (x:xs) = selectByMask ms xs
1107 \end{code}