[project @ 1998-12-02 13:17:09 by simonm]

[ghc-hetmet.git] / ghc / compiler / codeGen / CgCase.lhs

diff --git a/ghc/compiler/codeGen/CgCase.lhs b/ghc/compiler/codeGen/CgCase.lhs
index e5a7adf..f4da725 100644 (file)
--- a/ghc/compiler/codeGen/CgCase.lhs
+++ b/ghc/compiler/codeGen/CgCase.lhs
@@ -1,5 +1,7 @@
 %
 %

-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+%
+% $Id: CgCase.lhs,v 1.18 1998/12/02 13:17:46 simonm Exp $

 %
 %********************************************************
 %*                                                     *
 %
 %********************************************************
 %*                                                     *

@@ -8,63 +10,61 @@
 %********************************************************
 
 \begin{code}
 %********************************************************
 
 \begin{code}

-module CgCase (        cgCase, saveVolatileVarsAndRegs ) where
+module CgCase (        cgCase, saveVolatileVarsAndRegs, restoreCurrentCostCentre,
+               splitAlgTyConAppThroughNewTypes ) where

 
 #include "HsVersions.h"
 
 
 #include "HsVersions.h"
 

-import {-# SOURCE #-} CgExpr
+import {-# SOURCE #-} CgExpr  ( cgExpr )

 
 import CgMonad
 import StgSyn
 import AbsCSyn
 
 import AbsCUtils       ( mkAbstractCs, mkAbsCStmts, mkAlgAltsCSwitch,
 
 import CgMonad
 import StgSyn
 import AbsCSyn
 
 import AbsCUtils       ( mkAbstractCs, mkAbsCStmts, mkAlgAltsCSwitch,

-                         magicIdPrimRep, getAmodeRep
+                         getAmodeRep, nonemptyAbsC

                        )
                        )

-import CgBindery       ( getVolatileRegs, getArgAmode, getArgAmodes,
+import CoreSyn         ( isDeadBinder )
+import CgUpdate                ( reserveSeqFrame )
+import CgBindery       ( getVolatileRegs, getArgAmodes,

                          bindNewToReg, bindNewToTemp,
                          bindNewPrimToAmode,
                          bindNewToReg, bindNewToTemp,
                          bindNewPrimToAmode,

-                         rebindToAStack, rebindToBStack,
+                         rebindToStack, getCAddrMode,

                          getCAddrModeAndInfo, getCAddrModeIfVolatile,
                          getCAddrModeAndInfo, getCAddrModeIfVolatile,

-                         idInfoToAmode
-                       )
-import CgCon           ( buildDynCon, bindConArgs )
-import CgHeapery       ( heapCheck, yield )
-import CgRetConv       ( dataReturnConvAlg, dataReturnConvPrim,
-                         ctrlReturnConvAlg,
-                         DataReturnConvention(..), CtrlReturnConvention(..),
-                         assignPrimOpResultRegs,
-                         makePrimOpArgsRobust
+                         buildContLivenessMask, nukeDeadBindings

                        )
                        )

-import CgStackery      ( allocAStack, allocBStack, allocAStackTop, allocBStackTop )
-import CgTailCall      ( tailCallBusiness, performReturn )
-import CgUsages                ( getSpARelOffset, getSpBRelOffset, freeBStkSlot )
-import CLabel          ( mkVecTblLabel, mkReturnPtLabel, mkDefaultLabel,
-                         mkAltLabel
+import CgCon           ( bindConArgs, bindUnboxedTupleComponents )
+import CgHeapery       ( altHeapCheck, yield )
+import CgRetConv       ( dataReturnConvPrim, ctrlReturnConvAlg,
+                         CtrlReturnConvention(..)

                        )
                        )

-import ClosureInfo     ( mkConLFInfo, mkLFArgument, layOutDynCon )
-import CmdLineOpts     ( opt_SccProfilingOn, opt_GranMacros )
-import CostCentre      ( useCurrentCostCentre, CostCentre )
-import HeapOffs                ( VirtualSpBOffset, VirtualHeapOffset )
-import Id              ( idPrimRep, dataConTag, fIRST_TAG, ConTag,
-                         isDataCon, DataCon,
-                         idSetToList, GenId{-instance Uniquable,Eq-}, Id
+import CgStackery      ( allocPrimStack, allocStackTop,
+                         deAllocStackTop, freeStackSlots

                        )
                        )

-import Literal          ( Literal )
-import Maybes          ( catMaybes )
-import PrimOp          ( primOpCanTriggerGC, PrimOp(..),
-                         primOpStackRequired, StackRequirement(..)
+import CgTailCall      ( tailCallFun )
+import CgUsages                ( getSpRelOffset, getRealSp )
+import CLabel          ( CLabel, mkVecTblLabel, mkReturnPtLabel, 
+                         mkDefaultLabel, mkAltLabel, mkReturnInfoLabel,
+                         mkErrorStdEntryLabel, mkClosureTblLabel

                        )
                        )

-import PrimRep         ( getPrimRepSize, isFollowableRep, retPrimRepSize,
-                         PrimRep(..)
-                       )
-import TyCon           ( isEnumerationTyCon )
-import Type            ( typePrimRep,
-                         splitAlgTyConApp, splitAlgTyConApp_maybe,
-                         Type
+import ClosureInfo     ( mkLFArgument )
+import CmdLineOpts     ( opt_SccProfilingOn, opt_GranMacros )
+import CostCentre      ( CostCentre )
+import Id              ( Id, idPrimRep )
+import DataCon         ( DataCon, dataConTag, fIRST_TAG, ConTag,
+                         isUnboxedTupleCon, dataConType )
+import VarSet          ( varSetElems )
+import Const           ( Con(..), Literal )
+import PrimOp          ( primOpOutOfLine, PrimOp(..) )
+import PrimRep         ( getPrimRepSize, retPrimRepSize, PrimRep(..)

                        )
                        )

+import TyCon           ( TyCon, isEnumerationTyCon, isUnboxedTupleTyCon,
+                         isNewTyCon, isAlgTyCon,
+                         tyConDataCons, tyConFamilySize )
+import Type            ( GenType(..), typePrimRep, splitAlgTyConApp, Type,
+                         splitFunTys, applyTys )

 import Unique           ( Unique, Uniquable(..) )
 import Unique           ( Unique, Uniquable(..) )

-import Util            ( sortLt, isIn, isn'tIn, zipEqual )
+import Maybes          ( maybeToBool )

 import Outputable
 \end{code}
 
 import Outputable
 \end{code}
 

@@ -85,13 +85,13 @@ op which can trigger GC.
 
 A more interesting situation is this:
 
 
 A more interesting situation is this:
 

-\begin{verbatim}
+ \begin{verbatim}

        !A!;
        ...A...
        case x# of
          0#      -> !B!; ...B...
          default -> !C!; ...C...
        !A!;
        ...A...
        case x# of
          0#      -> !B!; ...B...
          default -> !C!; ...C...

-\end{verbatim}
+ \end{verbatim}

 
 where \tr{!x!} indicates a possible heap-check point. The heap checks
 in the alternatives {\em can} be omitted, in which case the topmost
 
 where \tr{!x!} indicates a possible heap-check point. The heap checks
 in the alternatives {\em can} be omitted, in which case the topmost

@@ -99,27 +99,21 @@ heapcheck will take their worst case into account.
 
 In favour of omitting \tr{!B!}, \tr{!C!}:
 
 
 In favour of omitting \tr{!B!}, \tr{!C!}:
 

-\begin{itemize}
-\item
-{\em May} save a heap overflow test,
+ - {\em May} save a heap overflow test,

        if ...A... allocates anything.  The other advantage
        of this is that we can use relative addressing
        from a single Hp to get at all the closures so allocated.
        if ...A... allocates anything.  The other advantage
        of this is that we can use relative addressing
        from a single Hp to get at all the closures so allocated.

-\item
- No need to save volatile vars etc across the case
-\end{itemize}
+
+ - No need to save volatile vars etc across the case

 
 Against:
 
 
 Against:
 

-\begin{itemize}
-\item
-   May do more allocation than reqd.  This sometimes bites us
+  - May do more allocation than reqd.  This sometimes bites us

        badly.  For example, nfib (ha!)  allocates about 30\% more space if the
        worst-casing is done, because many many calls to nfib are leaf calls
        which don't need to allocate anything.
 
        This never hurts us if there is only one alternative.
        badly.  For example, nfib (ha!)  allocates about 30\% more space if the
        worst-casing is done, because many many calls to nfib are leaf calls
        which don't need to allocate anything.
 
        This never hurts us if there is only one alternative.

-\end{itemize}

 
 
 *** NOT YET DONE ***  The difficulty is that \tr{!B!}, \tr{!C!} need
 
 
 *** NOT YET DONE ***  The difficulty is that \tr{!B!}, \tr{!C!} need

@@ -133,128 +127,32 @@ If these things are done, then the heap checks can be done at \tr{!B!} and
 cgCase :: StgExpr
        -> StgLiveVars
        -> StgLiveVars
 cgCase :: StgExpr
        -> StgLiveVars
        -> StgLiveVars

-       -> Unique
+       -> Id
+       -> SRT

        -> StgCaseAlts
        -> Code
 \end{code}
 
        -> StgCaseAlts
        -> Code
 \end{code}
 

-Several special cases for primitive operations.
-
+Several special cases for inline primitive operations.

 
 \begin{code}
 
 \begin{code}

-cgCase (StgPrim op args _) live_in_whole_case live_in_alts uniq alts
-  | not (primOpCanTriggerGC op)
+cgCase (StgCon (PrimOp op) args res_ty) live_in_whole_case live_in_alts bndr srt alts
+  | not (primOpOutOfLine op)

   =
        -- Get amodes for the arguments and results
   =
        -- Get amodes for the arguments and results

-    getPrimOpArgAmodes op args                 `thenFC` \ arg_amodes ->
+    getArgAmodes args                  `thenFC` \ arg_amodes ->

     let
     let

-       result_amodes = getPrimAppResultAmodes uniq alts
-       liveness_mask = panic "cgCase: liveness of non-GC-ing primop touched\n"
+       result_amodes = getPrimAppResultAmodes (getUnique bndr) alts

     in
        -- Perform the operation
     in
        -- Perform the operation

-    getVolatileRegs live_in_alts                       `thenFC` \ vol_regs ->
-
-    -- seq cannot happen here => no additional B Stack alloc
+    getVolatileRegs live_in_alts        `thenFC` \ vol_regs ->

 
     absC (COpStmt result_amodes op
                 arg_amodes -- note: no liveness arg
 
     absC (COpStmt result_amodes op
                 arg_amodes -- note: no liveness arg

-                liveness_mask vol_regs)                `thenC`
+                vol_regs)              `thenC`

 
        -- Scrutinise the result
 
        -- Scrutinise the result

-    cgInlineAlts NoGC uniq alts
-
-  | otherwise  -- *Can* trigger GC
-  = getPrimOpArgAmodes op args `thenFC` \ arg_amodes ->
-
-       -- Get amodes for the arguments and results, and assign to regs
-       -- (Can-trigger-gc primops guarantee to have their (nonRobust)
-       --  args in regs)
-    let
-       op_result_regs = assignPrimOpResultRegs op
-
-       op_result_amodes = map CReg op_result_regs
-
-       (op_arg_amodes, liveness_mask, arg_assts)
-         = makePrimOpArgsRobust op arg_amodes
-
-       liveness_arg  = mkIntCLit liveness_mask
-    in
-       -- Tidy up in case GC happens...
-
-       -- Nota Bene the use of live_in_whole_case in nukeDeadBindings.
-       -- Reason: the arg_assts computed above may refer to some stack slots
-       -- which are not live in the alts.  So we mustn't use those slots
-       -- to save volatile vars in!
-    nukeDeadBindings live_in_whole_case        `thenC`
-    saveVolatileVars live_in_alts      `thenFC` \ volatile_var_save_assts ->
-
-    -- Allocate stack words for the prim-op itself,
-    -- these are guaranteed to be ON TOP OF the stack.
-    -- Currently this is used *only* by the seq# primitive op.
-    let 
-      (a_req,b_req) = case (primOpStackRequired op) of
-                          NoStackRequired        -> (0, 0)
-                          FixedStackRequired a b -> (a, b)
-                          VariableStackRequired  -> (0, 0) -- i.e. don't care
-    in
-    allocAStackTop a_req               `thenFC` \ a_slot ->
-    allocBStackTop b_req               `thenFC` \ b_slot ->
-
-    getEndOfBlockInfo                  `thenFC` \ eob_info@(EndOfBlockInfo args_spa args_spb sequel) ->
-    -- a_req and b_req allocate stack space that is taken care of by the
-    -- macros generated for the primops; thus, we there is no need to adjust
-    -- this part of the stacks later on (=> +a_req in EndOfBlockInfo)
-    -- currently all this is only used for SeqOp
-    forkEval (if True {- a_req==0 && b_req==0 -}
-                then eob_info
-                else (EndOfBlockInfo (args_spa+a_req) 
-                                    (args_spb+b_req) sequel)) nopC 
-            (
-             getAbsC (cgInlineAlts GCMayHappen uniq alts) `thenFC` \ abs_c ->
-             absC (CRetUnVector vtbl_label (CLabelledCode return_label abs_c))
-                                       `thenC`
-             returnFC (CaseAlts (CUnVecLbl return_label vtbl_label)
-                                Nothing{-no semi-tagging-}))
-           `thenFC` \ new_eob_info ->
-
-       -- Record the continuation info
-    setEndOfBlockInfo new_eob_info (
-
-       -- Now "return" to the inline alternatives; this will get
-       -- compiled to a fall-through.
-    let
-       simultaneous_assts = arg_assts `mkAbsCStmts` volatile_var_save_assts
-
-       -- do_op_and_continue will be passed an amode for the continuation
-       do_op_and_continue sequel
-         = absC (COpStmt op_result_amodes
-                         op
-                         (pin_liveness op liveness_arg op_arg_amodes)
-                         liveness_mask
-                         [{-no vol_regs-}])
-                                       `thenC`
-
-           sequelToAmode sequel        `thenFC` \ dest_amode ->
-           absC (CReturn dest_amode DirectReturn)
-
-               -- Note: we CJump even for algebraic data types,
-               -- because cgInlineAlts always generates code, never a
-               -- vector.
-    in
-    performReturn simultaneous_assts do_op_and_continue live_in_alts
-    )
-  where
-    -- for all PrimOps except ccalls, we pin the liveness info
-    -- on as the first "argument"
-    -- ToDo: un-duplicate?
-
-    pin_liveness (CCallOp _ _ _ _ _) _ args = args
-    pin_liveness other_op liveness_arg args
-      = liveness_arg :args
-
-    vtbl_label = mkVecTblLabel uniq
-    return_label = mkReturnPtLabel uniq
-
+    cgInlineAlts bndr alts

 \end{code}
 
 Another special case: scrutinising a primitive-typed variable. No
 \end{code}
 
 Another special case: scrutinising a primitive-typed variable. No

@@ -265,9 +163,24 @@ allocating more heap than strictly necessary, but it will sometimes
 eliminate a heap check altogether.
 
 \begin{code}
 eliminate a heap check altogether.
 
 \begin{code}

-cgCase (StgApp v [] _) live_in_whole_case live_in_alts uniq (StgPrimAlts ty alts deflt)
-  = getArgAmode v              `thenFC` \ amode ->
-    cgPrimAltsGivenScrutinee NoGC amode alts deflt
+cgCase (StgApp v []) live_in_whole_case live_in_alts bndr srt
+                       (StgPrimAlts ty alts deflt)
+
+  = 
+    getCAddrMode v             `thenFC` \amode ->
+
+    {- 
+       Careful! we can't just bind the default binder to the same thing
+       as the scrutinee, since it might be a stack location, and having
+       two bindings pointing at the same stack locn doesn't work (it
+       confuses nukeDeadBindings).  Hence, use a new temp.
+    -}
+    (if (isDeadBinder bndr)
+       then nopC
+       else bindNewToTemp bndr  `thenFC`  \deflt_amode ->
+            absC (CAssign deflt_amode amode)) `thenC`
+
+    cgPrimAlts NoGC amode alts deflt []

 \end{code}
 
 Special case: scrutinising a non-primitive variable.
 \end{code}
 
 Special case: scrutinising a non-primitive variable.

@@ -275,8 +188,8 @@ This can be done a little better than the general case, because
 we can reuse/trim the stack slot holding the variable (if it is in one).
 
 \begin{code}
 we can reuse/trim the stack slot holding the variable (if it is in one).
 
 \begin{code}

-cgCase (StgApp (StgVarArg fun) args _ {-lvs must be same as live_in_alts-})
-       live_in_whole_case live_in_alts uniq alts@(StgAlgAlts _ _ _)
+cgCase (StgApp fun args)
+       live_in_whole_case live_in_alts bndr srt alts@(StgAlgAlts ty _ _)

   =
     getCAddrModeAndInfo fun            `thenFC` \ (fun_amode, lf_info) ->
     getArgAmodes args                  `thenFC` \ arg_amodes ->
   =
     getCAddrModeAndInfo fun            `thenFC` \ (fun_amode, lf_info) ->
     getArgAmodes args                  `thenFC` \ arg_amodes ->

@@ -286,31 +199,114 @@ cgCase (StgApp (StgVarArg fun) args _ {-lvs must be same as live_in_alts-})
     saveVolatileVarsAndRegs live_in_alts
                        `thenFC` \ (save_assts, alts_eob_info, maybe_cc_slot) ->
 
     saveVolatileVarsAndRegs live_in_alts
                        `thenFC` \ (save_assts, alts_eob_info, maybe_cc_slot) ->
 

-    forkEval alts_eob_info
-            nopC (cgEvalAlts maybe_cc_slot uniq alts) `thenFC` \ scrut_eob_info ->
-    setEndOfBlockInfo scrut_eob_info  (
-      tailCallBusiness fun fun_amode lf_info arg_amodes live_in_alts save_assts
-    )
+    allocStackTop retPrimRepSize       `thenFC` \_ ->
+
+    forkEval alts_eob_info nopC (
+               deAllocStackTop retPrimRepSize `thenFC` \_ ->
+               cgEvalAlts maybe_cc_slot bndr srt alts) 
+                                        `thenFC` \ scrut_eob_info ->
+
+    let real_scrut_eob_info =
+               if not_con_ty
+                       then reserveSeqFrame scrut_eob_info
+                       else scrut_eob_info
+    in
+
+    setEndOfBlockInfo real_scrut_eob_info (
+      tailCallFun fun fun_amode lf_info arg_amodes save_assts
+      )

 
 

+  where
+     not_con_ty = case (getScrutineeTyCon ty) of
+                       Just _ -> False
+                       other  -> True

 \end{code}
 
 \end{code}
 

+Note about return addresses: we *always* push a return address, even
+if because of an optimisation we end up jumping direct to the return
+code (not through the address itself).  The alternatives always assume
+that the return address is on the stack.  The return address is
+required in case the alternative performs a heap check, since it
+encodes the liveness of the slots in the activation record.
+
+On entry to the case alternative, we can re-use the slot containing
+the return address immediately after the heap check.  That's what the
+deAllocStackTop call is doing above.
+

 Finally, here is the general case.
 
 \begin{code}
 Finally, here is the general case.
 
 \begin{code}

-cgCase expr live_in_whole_case live_in_alts uniq alts
+cgCase expr live_in_whole_case live_in_alts bndr srt alts

   =    -- Figure out what volatile variables to save
     nukeDeadBindings live_in_whole_case        `thenC`
   =    -- Figure out what volatile variables to save
     nukeDeadBindings live_in_whole_case        `thenC`

+    

     saveVolatileVarsAndRegs live_in_alts
                        `thenFC` \ (save_assts, alts_eob_info, maybe_cc_slot) ->
 
     saveVolatileVarsAndRegs live_in_alts
                        `thenFC` \ (save_assts, alts_eob_info, maybe_cc_slot) ->
 

-       -- Save those variables right now!
+    -- Save those variables right now!

     absC save_assts                    `thenC`
 
     absC save_assts                    `thenC`
 

+    -- generate code for the alts

     forkEval alts_eob_info
     forkEval alts_eob_info

-       (nukeDeadBindings live_in_alts)
-       (cgEvalAlts maybe_cc_slot uniq alts) `thenFC` \ scrut_eob_info ->
+       (
+        nukeDeadBindings live_in_alts `thenC` 
+        allocStackTop retPrimRepSize   -- space for retn address 
+        `thenFC` \_ -> nopC
+        )
+       (deAllocStackTop retPrimRepSize `thenFC` \_ ->
+        cgEvalAlts maybe_cc_slot bndr srt alts) `thenFC` \ scrut_eob_info ->
+
+    let real_scrut_eob_info =
+               if not_con_ty
+                       then reserveSeqFrame scrut_eob_info
+                       else scrut_eob_info
+    in
+
+    setEndOfBlockInfo real_scrut_eob_info (cgExpr expr)

 
 

-    setEndOfBlockInfo scrut_eob_info (cgExpr expr)
+  where
+     not_con_ty = case (getScrutineeTyCon (alts_ty alts)) of
+                       Just _ -> False
+                       other  -> True
+\end{code}
+
+There's a lot of machinery going on behind the scenes to manage the
+stack pointer here.  forkEval takes the virtual Sp and free list from
+the first argument, and turns that into the *real* Sp for the second
+argument.  It also uses this virtual Sp as the args-Sp in the EOB info
+returned, so that the scrutinee will trim the real Sp back to the
+right place before doing whatever it does.  
+  --SDM (who just spent an hour figuring this out, and didn't want to 
+        forget it).
+
+Why don't we push the return address just before evaluating the
+scrutinee?  Because the slot reserved for the return address might
+contain something useful, so we wait until performing a tail call or
+return before pushing the return address (see
+CgTailCall.pushReturnAddress).  
+
+This also means that the environment doesn't need to know about the
+free stack slot for the return address (for generating bitmaps),
+because we don't reserve it until just before the eval.
+
+TODO!!  Problem: however, we have to save the current cost centre
+stack somewhere, because at the eval point the current CCS might be
+different.  So we pick a free stack slot and save CCCS in it.  The
+problem with this is that this slot isn't recorded as free/unboxed in
+the environment, so a case expression in the scrutinee will have the
+wrong bitmap attached.  Fortunately we don't ever seem to see
+case-of-case at the back end.  One solution might be to shift the
+saved CCS to the correct place in the activation record just before
+the jump.
+       --SDM
+
+(one consequence of the above is that activation records on the stack
+don't follow the layout of closures when we're profiling.  The CCS
+could be anywhere within the record).
+
+\begin{code}
+alts_ty (StgAlgAlts ty _ _) = ty
+alts_ty (StgPrimAlts ty _ _) = ty

 \end{code}
 
 %************************************************************************
 \end{code}
 
 %************************************************************************

@@ -352,40 +348,39 @@ getPrimAppResultAmodes
 -- Anyway, cgInlineAlts is now capable of handling all cases;
 -- it's only this function which is being wimpish.
 
 -- Anyway, cgInlineAlts is now capable of handling all cases;
 -- it's only this function which is being wimpish.
 

-getPrimAppResultAmodes uniq (StgAlgAlts ty alts (StgBindDefault _ True {- used -} _))
+getPrimAppResultAmodes uniq (StgAlgAlts ty alts 
+                               (StgBindDefault rhs))

   | isEnumerationTyCon spec_tycon = [tag_amode]
   | isEnumerationTyCon spec_tycon = [tag_amode]

-  | otherwise                    = panic "getPrimAppResultAmodes: non-enumeration algebraic alternatives with default"
+  | otherwise                    = pprPanic "getPrimAppResultAmodes: non-enumeration algebraic alternatives with default" (ppr uniq <+> ppr rhs)

   where
     -- A temporary variable to hold the tag; this is unaffected by GC because
     -- the heap-checks in the branches occur after the switch
     tag_amode     = CTemp uniq IntRep
     (spec_tycon, _, _) = splitAlgTyConApp ty
   where
     -- A temporary variable to hold the tag; this is unaffected by GC because
     -- the heap-checks in the branches occur after the switch
     tag_amode     = CTemp uniq IntRep
     (spec_tycon, _, _) = splitAlgTyConApp ty

+\end{code}

 
 

+If we don't have a default case, we could be scrutinising an unboxed
+tuple, or an enumeration type...
+
+\begin{code}

 getPrimAppResultAmodes uniq (StgAlgAlts ty alts other_default)
        -- Default is either StgNoDefault or StgBindDefault with unused binder
 getPrimAppResultAmodes uniq (StgAlgAlts ty alts other_default)
        -- Default is either StgNoDefault or StgBindDefault with unused binder

-  = case alts of
-       [_]     -> arg_amodes                   -- No need for a tag
-       other   -> tag_amode : arg_amodes
-  where
-    -- A temporary variable to hold the tag; this is unaffected by GC because
-    -- the heap-checks in the branches occur after the switch
-    tag_amode = CTemp uniq IntRep

 
 

-    -- Sort alternatives into canonical order; there must be a complete
-    -- set because there's no default case.
-    sorted_alts = sortLt lt alts
-    (con1,_,_,_) `lt` (con2,_,_,_) = dataConTag con1 < dataConTag con2
+  | isEnumerationTyCon tycon = [CTemp uniq IntRep]

 
 

-    arg_amodes :: [CAddrMode]
+  | isUnboxedTupleTyCon tycon = 
+       case alts of 
+           [(con, args, use_mask, rhs)] -> 
+               [ CTemp (getUnique arg) (idPrimRep arg) | arg <- args ]
+           _ -> panic "getPrimAppResultAmodes: case of unboxed tuple has multiple branches"

 
 

-    -- Turn them into amodes
-    arg_amodes = concat (map mk_amodes sorted_alts)
-    mk_amodes (con, args, use_mask, rhs)
-      = [ CTemp (uniqueOf arg) (idPrimRep arg) | arg <- args ]
+  | otherwise = panic ("getPrimAppResultAmodes: case of primop has strange type: " ++ showSDoc (ppr ty))
+
+  where (tycon, _, _) = splitAlgTyConApp ty

 \end{code}
 
 \end{code}
 

-The situation is simpler for primitive
-results, because there is only one!
+The situation is simpler for primitive results, because there is only
+one!

 
 \begin{code}
 getPrimAppResultAmodes uniq (StgPrimAlts ty _ _)
 
 \begin{code}
 getPrimAppResultAmodes uniq (StgPrimAlts ty _ _)

@@ -404,17 +399,35 @@ alternatives of a @case@, used in a context when there
 is some evaluation to be done.
 
 \begin{code}
 is some evaluation to be done.
 
 \begin{code}

-cgEvalAlts :: Maybe VirtualSpBOffset   -- Offset of cost-centre to be restored, if any
-          -> Unique
+cgEvalAlts :: Maybe VirtualSpOffset    -- Offset of cost-centre to be restored, if any
+          -> Id
+          -> SRT                       -- SRT for the continuation

           -> StgCaseAlts
           -> StgCaseAlts

-          -> FCode Sequel              -- Any addr modes inside are guaranteed to be a label
-                                       -- so that we can duplicate it without risk of
-                                       -- duplicating code
+          -> FCode Sequel      -- Any addr modes inside are guaranteed
+                               -- to be a label so that we can duplicate it 
+                               -- without risk of duplicating code
+
+cgEvalAlts cc_slot bndr srt alts
+  =    
+    let uniq = getUnique bndr in

 
 

-cgEvalAlts cc_slot uniq (StgAlgAlts ty alts deflt)
-  =    -- Generate the instruction to restore cost centre, if any
+    -- Generate the instruction to restore cost centre, if any

     restoreCurrentCostCentre cc_slot   `thenFC` \ cc_restore ->
 
     restoreCurrentCostCentre cc_slot   `thenFC` \ cc_restore ->
 

+    -- get the stack liveness for the info table (after the CC slot has
+    -- been freed - this is important).
+    buildContLivenessMask uniq         `thenFC` \ liveness_mask ->
+
+    case alts of
+
+      -- algebraic alts ...
+      (StgAlgAlts ty alts deflt) ->
+
+          -- bind the default binder (it covers all the alternatives)
+       (if (isDeadBinder bndr)
+               then nopC
+               else bindNewToReg bndr node mkLFArgument) `thenC`
+

        -- Generate sequel info for use downstream
        -- At the moment, we only do it if the type is vector-returnable.
        -- Reason: if not, then it costs extra to label the
        -- Generate sequel info for use downstream
        -- At the moment, we only do it if the type is vector-returnable.
        -- Reason: if not, then it costs extra to label the

@@ -424,48 +437,65 @@ cgEvalAlts cc_slot uniq (StgAlgAlts ty alts deflt)
        --
        -- which is worse than having the alt code in the switch statement
 
        --
        -- which is worse than having the alt code in the switch statement
 

-    let
-       (spec_tycon, _, _) = splitAlgTyConApp ty
-
-       use_labelled_alts
-         = case ctrlReturnConvAlg spec_tycon of
-             VectoredReturn _ -> True
-             _                -> False
-
-       semi_tagged_stuff
-         = if not use_labelled_alts then
-               Nothing -- no semi-tagging info
-           else
-               cgSemiTaggedAlts uniq alts deflt -- Just <something>
-    in
-    cgAlgAlts GCMayHappen uniq cc_restore use_labelled_alts ty alts deflt True
-                                       `thenFC` \ (tagged_alt_absCs, deflt_absC) ->
-
-    mkReturnVector uniq ty tagged_alt_absCs deflt_absC `thenFC` \ return_vec ->
-
-    returnFC (CaseAlts return_vec semi_tagged_stuff)
-
-cgEvalAlts cc_slot uniq (StgPrimAlts ty alts deflt)
-  =    -- Generate the instruction to restore cost centre, if any
-    restoreCurrentCostCentre cc_slot                    `thenFC` \ cc_restore ->
-
-       -- Generate the switch
-    getAbsC (cgPrimAlts GCMayHappen uniq ty alts deflt)  `thenFC` \ abs_c ->
+       let     tycon_info      = getScrutineeTyCon ty
+               is_alg          = maybeToBool tycon_info
+               Just spec_tycon = tycon_info
+       in
+
+       -- deal with the unboxed tuple case
+       if is_alg && isUnboxedTupleTyCon spec_tycon then
+           case alts of 
+               [alt] -> let lbl = mkReturnInfoLabel uniq in
+                        cgUnboxedTupleAlt lbl cc_restore True alt
+                               `thenFC` \ abs_c ->
+                        getSRTLabel `thenFC` \srt_label -> 
+                        absC (CRetDirect uniq abs_c (srt_label, srt) 
+                                       liveness_mask) `thenC`
+                       returnFC (CaseAlts (CLbl lbl RetRep) Nothing)
+               _ -> panic "cgEvalAlts: dodgy case of unboxed tuple type"
+
+       -- normal algebraic (or polymorphic) case alternatives
+       else let
+               ret_conv | is_alg    = ctrlReturnConvAlg spec_tycon
+                        | otherwise = UnvectoredReturn 0
+
+               use_labelled_alts = case ret_conv of
+                                       VectoredReturn _ -> True
+                                       _                -> False
+
+               semi_tagged_stuff
+                  = if use_labelled_alts then
+                       cgSemiTaggedAlts bndr alts deflt -- Just <something>
+                    else
+                       Nothing -- no semi-tagging info
+
+       in
+       cgAlgAlts GCMayHappen uniq cc_restore use_labelled_alts (not is_alg) 
+               alts deflt True `thenFC` \ (tagged_alt_absCs, deflt_absC) ->
+
+       mkReturnVector uniq tagged_alt_absCs deflt_absC srt liveness_mask 
+               ret_conv  `thenFC` \ return_vec ->
+
+       returnFC (CaseAlts return_vec semi_tagged_stuff)
+
+      -- primitive alts...
+      (StgPrimAlts ty alts deflt) ->
+
+       -- Generate the switch
+       getAbsC (cgPrimEvalAlts bndr ty alts deflt)     `thenFC` \ abs_c ->
+
+       -- Generate the labelled block, starting with restore-cost-centre
+       getSRTLabel                                     `thenFC` \srt_label ->
+       absC (CRetDirect uniq (cc_restore `mkAbsCStmts` abs_c) 
+                       (srt_label,srt) liveness_mask)  `thenC`

 
 

-       -- Generate the labelled block, starting with restore-cost-centre
-    absC (CRetUnVector vtbl_label
-        (CLabelledCode return_label (cc_restore `mkAbsCStmts` abs_c)))
-                                                        `thenC`

        -- Return an amode for the block
        -- Return an amode for the block

-    returnFC (CaseAlts (CUnVecLbl return_label vtbl_label) Nothing{-no semi-tagging-})
-  where
-    vtbl_label = mkVecTblLabel uniq
-    return_label = mkReturnPtLabel uniq
+       returnFC (CaseAlts (CLbl (mkReturnPtLabel uniq) RetRep) Nothing)

 \end{code}
 
 
 \begin{code}
 \end{code}
 
 
 \begin{code}

-cgInlineAlts :: GCFlag -> Unique
+cgInlineAlts :: Id

             -> StgCaseAlts
             -> Code
 \end{code}
             -> StgCaseAlts
             -> Code
 \end{code}

@@ -476,24 +506,44 @@ created, so we don't have to generate a GRAN_YIELD in that case.  This info
 must be  propagated  to cgAlgAltRhs (where the  GRAN_YIELD  macro might  be
 emitted). Hence, the new Bool arg to cgAlgAltRhs.
 
 must be  propagated  to cgAlgAltRhs (where the  GRAN_YIELD  macro might  be
 emitted). Hence, the new Bool arg to cgAlgAltRhs.
 

-First case: algebraic case, exactly one alternative, no default.
-In this case the primitive op will not have set a temporary to the
-tag, so we shouldn't generate a switch statment.  Instead we just
-do the right thing.
+First case: primitive op returns an unboxed tuple.
+
+\begin{code}
+cgInlineAlts bndr (StgAlgAlts ty [alt@(con,args,use_mask,rhs)] StgNoDefault)
+  | isUnboxedTupleCon con
+  = -- no heap check, no yield, just get in there and do it.
+    mapFCs bindNewToTemp args `thenFC` \ _ ->
+    cgExpr rhs
+
+  | otherwise
+  = panic "cgInlineAlts: single alternative, not an unboxed tuple"
+\end{code}
+
+Hack: to deal with 
+
+       case <# x y of z {
+          DEFAULT -> ...
+        }

 
 \begin{code}
 
 \begin{code}

-cgInlineAlts gc_flag uniq (StgAlgAlts ty [alt@(con,args,use_mask,rhs)] StgNoDefault)
-  = cgAlgAltRhs gc_flag con args use_mask rhs False{-no yield macro if alt gets inlined-}
+cgInlineAlts bndr (StgAlgAlts ty [] (StgBindDefault rhs))
+  = bindNewToTemp bndr                 `thenFC` \amode ->
+    let
+       (tycon, _, _) = splitAlgTyConApp ty
+       closure_lbl = CTableEntry (CLbl (mkClosureTblLabel tycon) PtrRep) amode PtrRep
+    in
+    absC (CAssign amode closure_lbl)   `thenC`
+    cgExpr rhs

 \end{code}
 
 Second case: algebraic case, several alternatives.
 Tag is held in a temporary.
 
 \begin{code}
 \end{code}
 
 Second case: algebraic case, several alternatives.
 Tag is held in a temporary.
 
 \begin{code}

-cgInlineAlts gc_flag uniq (StgAlgAlts ty alts deflt)
-  = cgAlgAlts gc_flag uniq AbsCNop{-restore_cc-} False{-no semi-tagging-}
-               ty alts deflt
-                False{-don't emit yield-}  `thenFC` \ (tagged_alts, deflt_c) ->
+cgInlineAlts bndr (StgAlgAlts ty alts deflt)
+  = cgAlgAlts NoGC uniq AbsCNop{-restore_cc-} False{-no semi-tagging-}
+               False{-not poly case-} alts deflt
+                False{-don't emit yield-}      `thenFC` \ (tagged_alts, deflt_c) ->

 
        -- Do the switch
     absC (mkAlgAltsCSwitch tag_amode tagged_alts deflt_c)
 
        -- Do the switch
     absC (mkAlgAltsCSwitch tag_amode tagged_alts deflt_c)

@@ -501,13 +551,14 @@ cgInlineAlts gc_flag uniq (StgAlgAlts ty alts deflt)
     -- A temporary variable to hold the tag; this is unaffected by GC because
     -- the heap-checks in the branches occur after the switch
     tag_amode = CTemp uniq IntRep
     -- A temporary variable to hold the tag; this is unaffected by GC because
     -- the heap-checks in the branches occur after the switch
     tag_amode = CTemp uniq IntRep

+    uniq = getUnique bndr

 \end{code}
 
 Third (real) case: primitive result type.
 
 \begin{code}
 \end{code}
 
 Third (real) case: primitive result type.
 
 \begin{code}

-cgInlineAlts gc_flag uniq (StgPrimAlts ty alts deflt)
-  = cgPrimAlts gc_flag uniq ty alts deflt
+cgInlineAlts bndr (StgPrimAlts ty alts deflt)
+  = cgPrimInlineAlts bndr ty alts deflt

 \end{code}
 
 
 \end{code}
 
 

@@ -530,165 +581,49 @@ cgAlgAlts :: GCFlag
          -> Unique
          -> AbstractC                          -- Restore-cost-centre instruction
          -> Bool                               -- True <=> branches must be labelled
          -> Unique
          -> AbstractC                          -- Restore-cost-centre instruction
          -> Bool                               -- True <=> branches must be labelled

-         -> Type                               -- From the case statement
-         -> [(Id, [Id], [Bool], StgExpr)]      -- The alternatives
-         -> StgCaseDefault             -- The default
+         -> Bool                               -- True <=> polymorphic case
+         -> [(DataCon, [Id], [Bool], StgExpr)] -- The alternatives
+         -> StgCaseDefault                     -- The default

           -> Bool                               -- Context switch at alts?
          -> FCode ([(ConTag, AbstractC)],      -- The branches
                    AbstractC                   -- The default case
             )
           -> Bool                               -- Context switch at alts?
          -> FCode ([(ConTag, AbstractC)],      -- The branches
                    AbstractC                   -- The default case
             )

-\end{code}

 
 

-The case with a default which has a binder is different.  We need to
-pick all the constructors which aren't handled explicitly by an
-alternative, and which return their results in registers, allocate
-them explicitly in the heap, and jump to a join point for the default
-case.
-
-OLD:  All of this only works if a heap-check is required anyway, because
-otherwise it isn't safe to allocate.
-
-NEW (July 94): now false!  It should work regardless of gc_flag,
-because of the extra_branches argument now added to forkAlts.
-
-We put a heap-check at the join point, for the benefit of constructors
-which don't need to do allocation. This means that ones which do need
-to allocate may end up doing two heap-checks; but that's just too bad.
-(We'd need two join labels otherwise.  ToDo.)
-
-It's all pretty turgid anyway.
-
-\begin{code}
-cgAlgAlts gc_flag uniq restore_cc semi_tagging
-       ty alts deflt@(StgBindDefault binder True{-used-} _)
-        emit_yield{-should a yield macro be emitted?-}
-  = let
-       extra_branches :: [FCode (ConTag, AbstractC)]
-       extra_branches = catMaybes (map mk_extra_branch default_cons)
-
-       must_label_default = semi_tagging || not (null extra_branches)
-    in
-    forkAlts (map (cgAlgAlt gc_flag uniq restore_cc semi_tagging emit_yield) alts)
-            extra_branches
-            (cgAlgDefault  gc_flag uniq restore_cc must_label_default deflt emit_yield)
-  where
-
-    default_join_lbl = mkDefaultLabel uniq
-    jump_instruction = CJump (CLbl default_join_lbl CodePtrRep)
-
-    (spec_tycon, _, spec_cons) = splitAlgTyConApp ty
-
-    alt_cons = [ con | (con,_,_,_) <- alts ]
-
-    default_cons  = [ spec_con | spec_con <- spec_cons,        -- In this type
-                                spec_con `not_elem` alt_cons ] -- Not handled explicitly
-       where
-         not_elem = isn'tIn "cgAlgAlts"
-
-    -- (mk_extra_branch con) returns the a maybe for the extra branch for con.
-    -- The "maybe" is because con may return in heap, in which case there is
-    -- nothing to do. Otherwise, we have a special case for a nullary constructor,
-    -- but in the general case we do an allocation and heap-check.
-
-    mk_extra_branch :: DataCon -> (Maybe (FCode (ConTag, AbstractC)))
-
-    mk_extra_branch con
-      = ASSERT(isDataCon con)
-       case dataReturnConvAlg con of
-         ReturnInHeap    -> Nothing
-         ReturnInRegs rs -> Just (getAbsC (alloc_code rs) `thenFC` \ abs_c ->
-                                  returnFC (tag, abs_c)
-                                 )
-      where
-       lf_info         = mkConLFInfo con
-       tag             = dataConTag con
-
-       -- alloc_code generates code to allocate constructor con, whose args are
-       -- in the arguments to alloc_code, assigning the result to Node.
-       alloc_code :: [MagicId] -> Code
-
-       alloc_code regs
-         = possibleHeapCheck gc_flag regs False (
-               buildDynCon binder useCurrentCostCentre con
-                               (map CReg regs) (all zero_size regs)
-                                               `thenFC` \ idinfo ->
-               idInfoToAmode PtrRep idinfo     `thenFC` \ amode ->
-
-               absC (CAssign (CReg node) amode) `thenC`
-               absC jump_instruction
-           )
-         where
-           zero_size reg = getPrimRepSize (magicIdPrimRep reg) == 0
-\end{code}
-
-Now comes the general case
-
-\begin{code}
-cgAlgAlts gc_flag uniq restore_cc must_label_branches ty alts deflt
-       {- The deflt is either StgNoDefault or a BindDefault which doesn't use the binder -}
+cgAlgAlts gc_flag uniq restore_cc must_label_branches is_fun alts deflt

           emit_yield{-should a yield macro be emitted?-}
 
   = forkAlts (map (cgAlgAlt gc_flag uniq restore_cc must_label_branches emit_yield) alts)
           emit_yield{-should a yield macro be emitted?-}
 
   = forkAlts (map (cgAlgAlt gc_flag uniq restore_cc must_label_branches emit_yield) alts)

-            [{- No "extra branches" -}]
-            (cgAlgDefault gc_flag uniq restore_cc must_label_branches deflt emit_yield)
+            (cgAlgDefault gc_flag is_fun uniq restore_cc must_label_branches deflt emit_yield)

 \end{code}
 
 \begin{code}
 cgAlgDefault :: GCFlag
 \end{code}
 
 \begin{code}
 cgAlgDefault :: GCFlag

+            -> Bool                    -- could be a function-typed result?

             -> Unique -> AbstractC -> Bool -- turgid state...
             -> Unique -> AbstractC -> Bool -- turgid state...

-            -> StgCaseDefault      -- input
+            -> StgCaseDefault          -- input

             -> Bool
             -> Bool

-            -> FCode AbstractC     -- output
+            -> FCode AbstractC         -- output

 
 

-cgAlgDefault gc_flag uniq restore_cc must_label_branch
-            StgNoDefault _
+cgAlgDefault gc_flag is_fun uniq restore_cc must_label_branch StgNoDefault _

   = returnFC AbsCNop
 
   = returnFC AbsCNop
 

-cgAlgDefault gc_flag uniq restore_cc must_label_branch
-            (StgBindDefault _ False{-binder not used-} rhs)
-             emit_yield{-should a yield macro be emitted?-}
-
-  = getAbsC (absC restore_cc `thenC`
-            let
-               emit_gran_macros = opt_GranMacros
-            in
-             (if emit_gran_macros && emit_yield 
-                then yield [] False 
-                else absC AbsCNop)                            `thenC`     
-    -- liveness same as in possibleHeapCheck below
-            possibleHeapCheck gc_flag [] False (cgExpr rhs)) `thenFC` \ abs_c ->
-    let
-       final_abs_c | must_label_branch = CJump (CLabelledCode lbl abs_c)
-                   | otherwise         = abs_c
-    in
-    returnFC final_abs_c
-  where
-    lbl = mkDefaultLabel uniq
-
-
-cgAlgDefault gc_flag uniq restore_cc must_label_branch
-            (StgBindDefault binder True{-binder used-} rhs)
+cgAlgDefault gc_flag is_fun uniq restore_cc must_label_branch
+            (StgBindDefault rhs)

           emit_yield{-should a yield macro be emitted?-}
 
           emit_yield{-should a yield macro be emitted?-}
 

-  =    -- We have arranged that Node points to the thing, even
-       -- even if we return in registers
-    bindNewToReg binder node mkLFArgument `thenC`
+  =    -- We have arranged that Node points to the thing

     getAbsC (absC restore_cc `thenC`
     getAbsC (absC restore_cc `thenC`

-            let
-               emit_gran_macros = opt_GranMacros
-            in
-             (if emit_gran_macros && emit_yield
+             (if opt_GranMacros && emit_yield

                 then yield [node] False
                 else absC AbsCNop)                            `thenC`     
                 then yield [node] False
                 else absC AbsCNop)                            `thenC`     

-               -- liveness same as in possibleHeapCheck below
-            possibleHeapCheck gc_flag [node] False (cgExpr rhs)
+            possibleHeapCheck gc_flag is_fun [node] [] Nothing (cgExpr rhs)

        -- Node is live, but doesn't need to point at the thing itself;
        -- it's ok for Node to point to an indirection or FETCH_ME
        -- Hence no need to re-enter Node.
     )                                  `thenFC` \ abs_c ->
 
     let
        -- Node is live, but doesn't need to point at the thing itself;
        -- it's ok for Node to point to an indirection or FETCH_ME
        -- Hence no need to re-enter Node.
     )                                  `thenFC` \ abs_c ->
 
     let

-       final_abs_c | must_label_branch = CJump (CLabelledCode lbl abs_c)
+       final_abs_c | must_label_branch = CCodeBlock lbl abs_c

                    | otherwise         = abs_c
     in
     returnFC final_abs_c
                    | otherwise         = abs_c
     in
     returnFC final_abs_c

@@ -700,18 +635,25 @@ cgAlgDefault gc_flag uniq restore_cc must_label_branch
 cgAlgAlt :: GCFlag
         -> Unique -> AbstractC -> Bool         -- turgid state
         -> Bool                               -- Context switch at alts?
 cgAlgAlt :: GCFlag
         -> Unique -> AbstractC -> Bool         -- turgid state
         -> Bool                               -- Context switch at alts?

-        -> (Id, [Id], [Bool], StgExpr)
+        -> (DataCon, [Id], [Bool], StgExpr)

         -> FCode (ConTag, AbstractC)
 
 cgAlgAlt gc_flag uniq restore_cc must_label_branch 
          emit_yield{-should a yield macro be emitted?-}
          (con, args, use_mask, rhs)
   = getAbsC (absC restore_cc `thenC`
         -> FCode (ConTag, AbstractC)
 
 cgAlgAlt gc_flag uniq restore_cc must_label_branch 
          emit_yield{-should a yield macro be emitted?-}
          (con, args, use_mask, rhs)
   = getAbsC (absC restore_cc `thenC`

-            cgAlgAltRhs gc_flag con args use_mask rhs 
-             emit_yield
+            (if opt_GranMacros && emit_yield
+               then yield [node] True          -- XXX live regs wrong
+               else absC AbsCNop)                               `thenC`     
+            (case gc_flag of
+               NoGC        -> mapFCs bindNewToTemp args `thenFC` \_ -> nopC
+               GCMayHappen -> bindConArgs con args
+            )  `thenC`
+            possibleHeapCheck gc_flag False [node] [] Nothing (
+            cgExpr rhs)

             ) `thenFC` \ abs_c -> 
     let
             ) `thenFC` \ abs_c -> 
     let

-       final_abs_c | must_label_branch = CJump (CLabelledCode lbl abs_c)
+       final_abs_c | must_label_branch = CCodeBlock lbl abs_c

                    | otherwise         = abs_c
     in
     returnFC (tag, final_abs_c)
                    | otherwise         = abs_c
     in
     returnFC (tag, final_abs_c)

@@ -719,38 +661,37 @@ cgAlgAlt gc_flag uniq restore_cc must_label_branch
     tag        = dataConTag con
     lbl = mkAltLabel uniq tag
 
     tag        = dataConTag con
     lbl = mkAltLabel uniq tag
 

-cgAlgAltRhs :: GCFlag 
-           -> Id 
-           -> [Id] 
-           -> [Bool] 
-           -> StgExpr 
-           -> Bool              -- context switch?
-           -> Code
-cgAlgAltRhs gc_flag con args use_mask rhs emit_yield
-  = let
-      (live_regs, node_reqd)
-       = case (dataReturnConvAlg con) of
-           ReturnInHeap      -> ([],                                             True)
-           ReturnInRegs regs -> ([reg | (reg,True) <- zipEqual "cgAlgAltRhs" regs use_mask], False)
-                               -- Pick the live registers using the use_mask
-                               -- Doing so is IMPORTANT, because with semi-tagging
-                               -- enabled only the live registers will have valid
-                               -- pointers in them.
-    in
-     let
-       emit_gran_macros = opt_GranMacros
-     in
-    (if emit_gran_macros && emit_yield
-      then yield live_regs node_reqd 
-      else absC AbsCNop)                                    `thenC`     
-    -- liveness same as in possibleHeapCheck below
-    possibleHeapCheck gc_flag live_regs node_reqd (
-    (case gc_flag of
-       NoGC        -> mapFCs bindNewToTemp args `thenFC` \ _ ->
-                      nopC
-       GCMayHappen -> bindConArgs con args
-    )  `thenC`
-    cgExpr rhs
+cgUnboxedTupleAlt
+       :: CLabel                       -- label of the alternative
+       -> AbstractC                    -- junk
+       -> Bool                         -- ctxt switch
+       -> (DataCon, [Id], [Bool], StgExpr) -- alternative
+       -> FCode AbstractC
+
+cgUnboxedTupleAlt lbl restore_cc emit_yield (con,args,use_mask,rhs)
+  = getAbsC (
+       absC restore_cc `thenC`
+
+       bindUnboxedTupleComponents args 
+                     `thenFC` \ (live_regs,tags,stack_res) ->
+       (if opt_GranMacros && emit_yield
+           then yield live_regs True           -- XXX live regs wrong?
+           else absC AbsCNop)                         `thenC`     
+       let 
+             -- ToDo: could maybe use Nothing here if stack_res is False
+             -- since the heap-check can just return to the top of the 
+             -- stack.
+             ret_addr = Just lbl
+       in
+
+       -- free up stack slots containing tags,
+       freeStackSlots (map fst tags)           `thenC`
+
+       -- generate a heap check if necessary
+       possibleHeapCheck GCMayHappen False live_regs tags ret_addr (
+
+       -- and finally the code for the alternative
+       cgExpr rhs)

     )
 \end{code}
 
     )
 \end{code}
 

@@ -764,60 +705,34 @@ Turgid-but-non-monadic code to conjure up the required info from
 algebraic case alternatives for semi-tagging.
 
 \begin{code}
 algebraic case alternatives for semi-tagging.
 
 \begin{code}

-cgSemiTaggedAlts :: Unique
-                -> [(Id, [Id], [Bool], StgExpr)]
+cgSemiTaggedAlts :: Id
+                -> [(DataCon, [Id], [Bool], StgExpr)]

                 -> GenStgCaseDefault Id Id
                 -> SemiTaggingStuff
 
                 -> GenStgCaseDefault Id Id
                 -> SemiTaggingStuff
 

-cgSemiTaggedAlts uniq alts deflt
+cgSemiTaggedAlts binder alts deflt

   = Just (map st_alt alts, st_deflt deflt)
   where
   = Just (map st_alt alts, st_deflt deflt)
   where

+    uniq        = getUnique binder
+

     st_deflt StgNoDefault = Nothing
 
     st_deflt StgNoDefault = Nothing
 

-    st_deflt (StgBindDefault binder binder_used _)
-      = Just (if binder_used then Just binder else Nothing,
+    st_deflt (StgBindDefault _)
+      = Just (Just binder,

              (CCallProfCtrMacro SLIT("RET_SEMI_BY_DEFAULT") [], -- ToDo: monadise?
               mkDefaultLabel uniq)
             )
 
     st_alt (con, args, use_mask, _)
              (CCallProfCtrMacro SLIT("RET_SEMI_BY_DEFAULT") [], -- ToDo: monadise?
               mkDefaultLabel uniq)
             )
 
     st_alt (con, args, use_mask, _)

-      = case (dataReturnConvAlg con) of
-
-         ReturnInHeap ->
-           -- Ha!  Nothing to do; Node already points to the thing
-           (con_tag,
-            (CCallProfCtrMacro SLIT("RET_SEMI_IN_HEAP") -- ToDo: monadise?
-                       [mkIntCLit (length args)], -- how big the thing in the heap is
+      =  -- Ha!  Nothing to do; Node already points to the thing
+        (con_tag,
+          (CCallProfCtrMacro SLIT("RET_SEMI_IN_HEAP") -- ToDo: monadise?
+               [mkIntCLit (length args)], -- how big the thing in the heap is

             join_label)
            )
             join_label)
            )

-
-         ReturnInRegs regs ->
-           -- We have to load the live registers from the constructor
-           -- pointed to by Node.
-           let
-               (_, regs_w_offsets) = layOutDynCon con magicIdPrimRep regs
-
-               used_regs = selectByMask use_mask regs
-
-               used_regs_w_offsets = [ ro | ro@(reg,offset) <- regs_w_offsets,
-                                            reg `is_elem` used_regs]
-
-               is_elem = isIn "cgSemiTaggedAlts"
-           in
-           (con_tag,
-            (mkAbstractCs [
-               CCallProfCtrMacro SLIT("RET_SEMI_IN_REGS")  -- ToDo: macroise?
-                       [mkIntCLit (length regs_w_offsets),
-                        mkIntCLit (length used_regs_w_offsets)],
-               CSimultaneous (mkAbstractCs (map move_to_reg used_regs_w_offsets))],
-             join_label))

       where
        con_tag     = dataConTag con
        join_label  = mkAltLabel uniq con_tag
       where
        con_tag     = dataConTag con
        join_label  = mkAltLabel uniq con_tag

-
-    move_to_reg :: (MagicId, VirtualHeapOffset {-from Node-}) -> AbstractC
-    move_to_reg (reg, offset)
-      = CAssign (CReg reg) (CVal (NodeRel offset) (magicIdPrimRep reg))

 \end{code}
 
 %************************************************************************
 \end{code}
 
 %************************************************************************

@@ -826,69 +741,63 @@ cgSemiTaggedAlts uniq alts deflt
 %*                                                                     *
 %************************************************************************
 
 %*                                                                     *
 %************************************************************************
 

-@cgPrimAlts@ generates a suitable @CSwitch@ for dealing with the
-alternatives of a primitive @case@, given an addressing mode for the
-thing to scrutinise.  It also keeps track of the maximum stack depth
-encountered down any branch.
+@cgPrimEvalAlts@ and @cgPrimInlineAlts@ generate suitable @CSwitch@es
+for dealing with the alternatives of a primitive @case@, given an
+addressing mode for the thing to scrutinise.  It also keeps track of
+the maximum stack depth encountered down any branch.

 
 As usual, no binders in the alternatives are yet bound.
 
 \begin{code}
 
 As usual, no binders in the alternatives are yet bound.
 
 \begin{code}

-cgPrimAlts :: GCFlag
-          -> Unique
-          -> Type
-          -> [(Literal, StgExpr)]      -- Alternatives
-          -> StgCaseDefault            -- Default
-          -> Code
-
-cgPrimAlts gc_flag uniq ty alts deflt
-  = cgPrimAltsGivenScrutinee gc_flag scrutinee alts deflt
- where
-    -- A temporary variable, or standard register, to hold the result
-    scrutinee = case gc_flag of
-                    NoGC        -> CTemp uniq kind
-                    GCMayHappen -> CReg (dataReturnConvPrim kind)
+cgPrimInlineAlts bndr ty alts deflt
+  = cgPrimAltsWithDefault bndr NoGC (CTemp uniq kind) alts deflt []
+  where
+       uniq = getUnique bndr
+       kind = typePrimRep ty

 
 

-    kind = typePrimRep ty
+cgPrimEvalAlts bndr ty alts deflt
+  = cgPrimAltsWithDefault bndr GCMayHappen (CReg reg) alts deflt [reg]
+  where
+       reg = dataReturnConvPrim kind
+       kind = typePrimRep ty

 
 

+cgPrimAltsWithDefault bndr gc_flag scrutinee alts deflt regs
+  =    -- first bind the default if necessary
+    (if isDeadBinder bndr 
+       then nopC
+       else bindNewPrimToAmode bndr scrutinee)         `thenC`
+    cgPrimAlts gc_flag scrutinee alts deflt regs
+
+cgPrimAlts gc_flag scrutinee alts deflt regs
+  = forkAlts (map (cgPrimAlt gc_flag regs) alts)
+            (cgPrimDefault gc_flag regs deflt) 
+                                       `thenFC` \ (alt_absCs, deflt_absC) ->

 
 

-cgPrimAltsGivenScrutinee gc_flag scrutinee alts deflt
-  = forkAlts (map (cgPrimAlt gc_flag) alts)
-            [{- No "extra branches" -}]
-            (cgPrimDefault gc_flag scrutinee deflt) `thenFC` \ (alt_absCs, deflt_absC) ->

     absC (CSwitch scrutinee alt_absCs deflt_absC)
     absC (CSwitch scrutinee alt_absCs deflt_absC)

-         -- CSwitch does sensible things with one or zero alternatives
+       -- CSwitch does sensible things with one or zero alternatives

 
 
 cgPrimAlt :: GCFlag
 
 
 cgPrimAlt :: GCFlag

-         -> (Literal, StgExpr)    -- The alternative
+         -> [MagicId]                  -- live registers
+         -> (Literal, StgExpr)         -- The alternative

          -> FCode (Literal, AbstractC) -- Its compiled form
 
          -> FCode (Literal, AbstractC) -- Its compiled form
 

-cgPrimAlt gc_flag (lit, rhs)
+cgPrimAlt gc_flag regs (lit, rhs)

   = getAbsC rhs_code    `thenFC` \ absC ->
     returnFC (lit,absC)
   where
   = getAbsC rhs_code    `thenFC` \ absC ->
     returnFC (lit,absC)
   where

-    rhs_code = possibleHeapCheck gc_flag [] False (cgExpr rhs )
+    rhs_code = possibleHeapCheck gc_flag False regs [] Nothing (cgExpr rhs)

 
 cgPrimDefault :: GCFlag
 
 cgPrimDefault :: GCFlag

-             -> CAddrMode              -- Scrutinee
+             -> [MagicId]              -- live registers

              -> StgCaseDefault
              -> FCode AbstractC
 
              -> StgCaseDefault
              -> FCode AbstractC
 

-cgPrimDefault gc_flag scrutinee StgNoDefault
+cgPrimDefault gc_flag regs StgNoDefault

   = panic "cgPrimDefault: No default in prim case"
 
   = panic "cgPrimDefault: No default in prim case"
 

-cgPrimDefault gc_flag scrutinee (StgBindDefault _ False{-binder not used-} rhs)
-  = getAbsC (possibleHeapCheck gc_flag [] False (cgExpr rhs ))
-
-cgPrimDefault gc_flag scrutinee (StgBindDefault binder True{-used-} rhs)
-  = getAbsC (possibleHeapCheck gc_flag regs False rhs_code)
-  where
-    regs = if isFollowableRep (getAmodeRep scrutinee) then
-             [node] else []
-
-    rhs_code = bindNewPrimToAmode binder scrutinee `thenC`
-              cgExpr rhs
+cgPrimDefault gc_flag regs (StgBindDefault rhs)
+  = getAbsC (possibleHeapCheck gc_flag False regs [] Nothing (cgExpr rhs))

 \end{code}
 
 
 \end{code}
 
 

@@ -900,19 +809,18 @@ cgPrimDefault gc_flag scrutinee (StgBindDefault binder True{-used-} rhs)
 
 \begin{code}
 saveVolatileVarsAndRegs
 
 \begin{code}
 saveVolatileVarsAndRegs

-    :: StgLiveVars               -- Vars which should be made safe
+    :: StgLiveVars                    -- Vars which should be made safe

     -> FCode (AbstractC,              -- Assignments to do the saves
     -> FCode (AbstractC,              -- Assignments to do the saves

-       EndOfBlockInfo,                -- New sequel, recording where the return
-                                     -- address now is
-       Maybe VirtualSpBOffset)        -- Slot for current cost centre
+             EndOfBlockInfo,         -- sequel for the alts
+              Maybe VirtualSpOffset)  -- Slot for current cost centre

 
 
 saveVolatileVarsAndRegs vars
 
 
 saveVolatileVarsAndRegs vars

-  = saveVolatileVars vars     `thenFC` \ var_saves ->
-    saveCurrentCostCentre     `thenFC` \ (maybe_cc_slot, cc_save) ->
-    saveReturnAddress         `thenFC` \ (new_eob_info, ret_save) ->
-    returnFC (mkAbstractCs [var_saves, cc_save, ret_save],
-             new_eob_info,
+  = saveVolatileVars vars       `thenFC` \ var_saves ->
+    saveCurrentCostCentre      `thenFC` \ (maybe_cc_slot, cc_save) ->
+    getEndOfBlockInfo           `thenFC` \ eob_info ->
+    returnFC (mkAbstractCs [var_saves, cc_save],
+             eob_info,

              maybe_cc_slot)
 
 
              maybe_cc_slot)
 
 

@@ -920,7 +828,7 @@ saveVolatileVars :: StgLiveVars     -- Vars which should be made safe
                 -> FCode AbstractC     -- Assignments to to the saves
 
 saveVolatileVars vars
                 -> FCode AbstractC     -- Assignments to to the saves
 
 saveVolatileVars vars

-  = save_em (idSetToList vars)
+  = save_em (varSetElems vars)

   where
     save_em [] = returnFC AbsCNop
 
   where
     save_em [] = returnFC AbsCNop
 

@@ -936,101 +844,48 @@ saveVolatileVars vars
                               returnFC (abs_c `mkAbsCStmts` abs_cs)
 
     save_var var vol_amode
                               returnFC (abs_c `mkAbsCStmts` abs_cs)
 
     save_var var vol_amode

-      | isFollowableRep kind
-      = allocAStack                    `thenFC` \ a_slot ->
-       rebindToAStack var a_slot       `thenC`
-       getSpARelOffset a_slot          `thenFC` \ spa_rel ->
-       returnFC (CAssign (CVal spa_rel kind) vol_amode)
-      | otherwise
-      = allocBStack (getPrimRepSize kind)      `thenFC` \ b_slot ->
-       rebindToBStack var b_slot       `thenC`
-       getSpBRelOffset b_slot          `thenFC` \ spb_rel ->
-       returnFC (CAssign (CVal spb_rel kind) vol_amode)
+      = allocPrimStack (getPrimRepSize kind)   `thenFC` \ slot ->
+       rebindToStack var slot          `thenC`
+       getSpRelOffset slot             `thenFC` \ sp_rel ->
+       returnFC (CAssign (CVal sp_rel kind) vol_amode)

       where
        kind = getAmodeRep vol_amode
       where
        kind = getAmodeRep vol_amode

-
-saveReturnAddress :: FCode (EndOfBlockInfo, AbstractC)
-saveReturnAddress
-  = getEndOfBlockInfo                `thenFC` \ eob_info@(EndOfBlockInfo vA vB sequel) ->
-
-      -- See if it is volatile
-    case sequel of
-      InRetReg ->     -- Yes, it's volatile
-                  allocBStack retPrimRepSize    `thenFC` \ b_slot ->
-                  getSpBRelOffset b_slot      `thenFC` \ spb_rel ->
-
-                  returnFC (EndOfBlockInfo vA vB (OnStack b_slot),
-                            CAssign (CVal spb_rel RetRep) (CReg RetReg))
-
-      UpdateCode _ ->   -- It's non-volatile all right, but we still need
-                       -- to allocate a B-stack slot for it, *solely* to make
-                       -- sure that update frames for different values do not
-                       -- appear adjacent on the B stack. This makes sure
-                       -- that B-stack squeezing works ok.
-                       -- See note below
-                  allocBStack retPrimRepSize    `thenFC` \ b_slot ->
-                  returnFC (eob_info, AbsCNop)
-
-      other ->          -- No, it's non-volatile, so do nothing
-                  returnFC (eob_info, AbsCNop)

 \end{code}
 
 \end{code}
 

-Note about B-stack squeezing.  Consider the following:`
-
-       y = [...] \u [] -> ...
-       x = [y]   \u [] -> case y of (a,b) -> a
-
-The code for x will push an update frame, and then enter y.  The code
-for y will push another update frame.  If the B-stack-squeezer then
-wakes up, it will see two update frames right on top of each other,
-and will combine them.  This is WRONG, of course, because x's value is
-not the same as y's.
-
-The fix implemented above makes sure that we allocate an (unused)
-B-stack slot before entering y.  You can think of this as holding the
-saved value of RetAddr, which (after pushing x's update frame will be
-some update code ptr).  The compiler is clever enough to load the
-static update code ptr into RetAddr before entering ~a~, but the slot
-is still there to separate the update frames.
+---------------------------------------------------------------------------

 
 When we save the current cost centre (which is done for lexical
 
 When we save the current cost centre (which is done for lexical

-scoping), we allocate a free B-stack location, and return (a)~the
+scoping), we allocate a free stack location, and return (a)~the

 virtual offset of the location, to pass on to the alternatives, and
 (b)~the assignment to do the save (just as for @saveVolatileVars@).
 
 \begin{code}
 saveCurrentCostCentre ::
 virtual offset of the location, to pass on to the alternatives, and
 (b)~the assignment to do the save (just as for @saveVolatileVars@).
 
 \begin{code}
 saveCurrentCostCentre ::

-       FCode (Maybe VirtualSpBOffset,  -- Where we decide to store it
-                                       --   Nothing if not lexical CCs
+       FCode (Maybe VirtualSpOffset,   -- Where we decide to store it

               AbstractC)               -- Assignment to save it
               AbstractC)               -- Assignment to save it

-                                       --   AbsCNop if not lexical CCs

 
 saveCurrentCostCentre
 
 saveCurrentCostCentre

-  = let
-       doing_profiling = opt_SccProfilingOn
-    in
-    if not doing_profiling then
+  = if not opt_SccProfilingOn then

        returnFC (Nothing, AbsCNop)
     else
        returnFC (Nothing, AbsCNop)
     else

-       allocBStack (getPrimRepSize CostCentreRep) `thenFC` \ b_slot ->
-       getSpBRelOffset b_slot                   `thenFC` \ spb_rel ->
-       returnFC (Just b_slot,
-                 CAssign (CVal spb_rel CostCentreRep) (CReg CurCostCentre))
+       allocPrimStack (getPrimRepSize CostCentreRep)  `thenFC` \ slot ->
+       getSpRelOffset slot                           `thenFC` \ sp_rel ->
+       returnFC (Just slot,
+                 CAssign (CVal sp_rel CostCentreRep) (CReg CurCostCentre))

 
 

-restoreCurrentCostCentre :: Maybe VirtualSpBOffset -> FCode AbstractC
+restoreCurrentCostCentre :: Maybe VirtualSpOffset -> FCode AbstractC

 
 restoreCurrentCostCentre Nothing
  = returnFC AbsCNop
 
 restoreCurrentCostCentre Nothing
  = returnFC AbsCNop

-restoreCurrentCostCentre (Just b_slot)
- = getSpBRelOffset b_slot                       `thenFC` \ spb_rel ->
-   freeBStkSlot b_slot                          `thenC`
-   returnFC (CCallProfCCMacro SLIT("RESTORE_CCC") [CVal spb_rel CostCentreRep])
-    -- we use the RESTORE_CCC macro, rather than just
+restoreCurrentCostCentre (Just slot)
+ = getSpRelOffset slot                          `thenFC` \ sp_rel ->
+   freeStackSlots [slot]                        `thenC`
+   returnFC (CCallProfCCMacro SLIT("RESTORE_CCCS") [CVal sp_rel CostCentreRep])
+    -- we use the RESTORE_CCCS macro, rather than just

     -- assigning into CurCostCentre, in case RESTORE_CCC
     -- has some sanity-checking in it.
 \end{code}
 
     -- assigning into CurCostCentre, in case RESTORE_CCC
     -- has some sanity-checking in it.
 \end{code}
 

-

 %************************************************************************
 %*                                                                     *
 \subsection[CgCase-return-vec]{Building a return vector}
 %************************************************************************
 %*                                                                     *
 \subsection[CgCase-return-vec]{Building a return vector}

@@ -1042,34 +897,52 @@ mode for it.
 
 \begin{code}
 mkReturnVector :: Unique
 
 \begin{code}
 mkReturnVector :: Unique

-              -> Type

               -> [(ConTag, AbstractC)] -- Branch codes
               -> AbstractC             -- Default case
               -> [(ConTag, AbstractC)] -- Branch codes
               -> AbstractC             -- Default case

+              -> SRT                   -- continuation's SRT
+              -> Liveness              -- stack liveness
+              -> CtrlReturnConvention

               -> FCode CAddrMode
 
               -> FCode CAddrMode
 

-mkReturnVector uniq ty tagged_alt_absCs deflt_absC
-  = let
-     (return_vec_amode, vtbl_body) = case (ctrlReturnConvAlg tycon) of {
-
-      UnvectoredReturn _ ->
-       (CUnVecLbl ret_label vtbl_label,
-        absC (CRetUnVector vtbl_label
-                           (CLabelledCode ret_label
-                                          (mkAlgAltsCSwitch (CReg TagReg)
-                                                            tagged_alt_absCs
-                                                            deflt_absC))));
+mkReturnVector uniq tagged_alt_absCs deflt_absC srt liveness ret_conv
+  = getSRTLabel `thenFC` \srt_label ->
+    let
+     srt_info = (srt_label, srt)
+
+     (return_vec_amode, vtbl_body) = case ret_conv of {
+
+       -- might be a polymorphic case...
+      UnvectoredReturn 0 ->
+       ASSERT(null tagged_alt_absCs)
+       (CLbl ret_label RetRep,
+        absC (CRetDirect uniq deflt_absC (srt_label, srt) liveness));
+
+      UnvectoredReturn n ->
+        -- find the tag explicitly rather than using tag_reg for now.
+       -- on architectures with lots of regs the tag will be loaded
+       -- into tag_reg by the code doing the returning.
+        let
+         tag = CMacroExpr WordRep GET_TAG [CVal (nodeRel 0) DataPtrRep]
+        in
+       (CLbl ret_label RetRep,
+        absC (CRetDirect uniq 
+                           (mkAlgAltsCSwitch tag tagged_alt_absCs deflt_absC)
+                           (srt_label, srt)
+                           liveness));
+

       VectoredReturn table_size ->
       VectoredReturn table_size ->

-       (CLbl vtbl_label DataPtrRep,
-        absC (CRetVector vtbl_label
-                       -- must restore cc before each alt, if required
-                         (map mk_vector_entry [fIRST_TAG .. (table_size+fIRST_TAG-1)])
-                         deflt_absC))
-
--- Leave nops and comments in for now; they are eliminated
--- lazily as it's printed.
---                       (case (nonemptyAbsC deflt_absC) of
---                             Nothing  -> AbsCNop
---                             Just def -> def)
+       let
+         (vector_table, alts_absC) = 
+           unzip (map mk_vector_entry [fIRST_TAG .. (table_size+fIRST_TAG-1)])
+
+         ret_vector = CRetVector vtbl_label
+                         vector_table
+                         (srt_label, srt) liveness
+       in
+       (CLbl vtbl_label DataPtrRep, 
+        -- alts come first, because we don't want to declare all the symbols
+        absC (mkAbstractCs (mkAbstractCs alts_absC : [deflt_absC,ret_vector]))
+       )

 
     } in
     vtbl_body                                              `thenC`
 
     } in
     vtbl_body                                              `thenC`

@@ -1077,22 +950,20 @@ mkReturnVector uniq ty tagged_alt_absCs deflt_absC
     -- )
   where
 
     -- )
   where
 

-    (tycon,_,_) = case splitAlgTyConApp_maybe ty of -- *must* be a real "data" type constructor
-             Just xx -> xx
-             Nothing -> pprPanic "ERROR: can't generate code for polymorphic case"
-                                 (vcat [text "probably a mis-use of `seq' or `par';",
-                                        text "the User's Guide has more details.",
-                                        text "Offending type:" <+> ppr ty
-                                 ])
-

     vtbl_label = mkVecTblLabel uniq
     vtbl_label = mkVecTblLabel uniq

-    ret_label = mkReturnPtLabel uniq
+    ret_label = mkReturnInfoLabel uniq
+
+    deflt_lbl = 
+       case nonemptyAbsC deflt_absC of
+                -- the simplifier might have eliminated a case
+          Nothing -> CLbl mkErrorStdEntryLabel CodePtrRep 
+          Just absC@(CCodeBlock lbl _) -> CLbl lbl CodePtrRep

 
 

-    mk_vector_entry :: ConTag -> Maybe CAddrMode
+    mk_vector_entry :: ConTag -> (CAddrMode, AbstractC)

     mk_vector_entry tag
       = case [ absC | (t, absC) <- tagged_alt_absCs, t == tag ] of
     mk_vector_entry tag
       = case [ absC | (t, absC) <- tagged_alt_absCs, t == tag ] of

-            []     -> Nothing
-            [absC] -> Just (CCode absC)
+            []     -> (deflt_lbl, AbsCNop)
+            [absC@(CCodeBlock lbl _)] -> (CLbl lbl CodePtrRep,absC)

             _      -> panic "mkReturnVector: too many"
 \end{code}
 
             _      -> panic "mkReturnVector: too many"
 \end{code}
 

@@ -1102,20 +973,61 @@ mkReturnVector uniq ty tagged_alt_absCs deflt_absC
 %*                                                                     *
 %************************************************************************
 
 %*                                                                     *
 %************************************************************************
 

-@possibleHeapCheck@ tests a flag passed in to decide whether to
-do a heap check or not.
+@possibleHeapCheck@ tests a flag passed in to decide whether to do a
+heap check or not.  These heap checks are always in a case
+alternative, so we use altHeapCheck.

 
 \begin{code}
 
 \begin{code}

-possibleHeapCheck :: GCFlag -> [MagicId] -> Bool -> Code -> Code
+possibleHeapCheck 
+       :: GCFlag 
+       -> Bool                         --  True <=> algebraic case
+       -> [MagicId]                    --  live registers
+       -> [(VirtualSpOffset,Int)]      --  stack slots to tag
+       -> Maybe CLabel                 --  return address
+       -> Code                         --  continuation
+       -> Code

 
 

-possibleHeapCheck GCMayHappen regs node_reqd code = heapCheck regs node_reqd code
-possibleHeapCheck NoGC       _    _         code = code
+possibleHeapCheck GCMayHappen is_alg regs tags lbl code 
+  = altHeapCheck is_alg regs tags AbsCNop lbl code
+possibleHeapCheck NoGC _ _ tags lbl code 
+  = code

 \end{code}
 
 \end{code}
 

-Select a restricted set of registers based on a usage mask.
+splitTyConAppThroughNewTypes is like splitAlgTyConApp_maybe except
+that it looks through newtypes in addition to synonyms.  It's
+useful in the back end where we're not interested in newtypes
+anymore.
+
+Sometimes, we've thrown away the constructors during pruning in the
+renamer.  In these cases, we emit a warning and fall back to using a
+SEQ_FRAME to evaluate the case scrutinee.

 
 \begin{code}
 
 \begin{code}

-selectByMask []                []         = []
-selectByMask (True:ms)  (x:xs) = x : selectByMask ms xs
-selectByMask (False:ms) (x:xs) = selectByMask ms xs
+getScrutineeTyCon :: Type -> Maybe TyCon
+getScrutineeTyCon ty =
+   case (splitAlgTyConAppThroughNewTypes ty) of
+       Nothing -> Nothing
+       Just (tc,_) -> 
+               if not (isAlgTyCon tc) then Just tc else
+               case (tyConFamilySize tc) of
+                       0 -> pprTrace "Warning" (hcat [
+                               text "constructors for ",
+                               ppr tc,
+                               text " not available.\n\tUse -fno-prune-tydecls to fix."
+                               ]) Nothing
+                       _ -> Just tc
+
+splitAlgTyConAppThroughNewTypes  :: Type -> Maybe (TyCon, [Type])
+splitAlgTyConAppThroughNewTypes (TyConApp tc tys) 
+       | isNewTyCon tc = 
+               case (tyConDataCons tc) of
+                       [con] -> let ([ty], _) = splitFunTys 
+                                             (applyTys (dataConType con) tys)
+                                in  splitAlgTyConAppThroughNewTypes ty
+                       _ -> Nothing
+       | otherwise = Just (tc, tys)
+
+splitAlgTyConAppThroughNewTypes (NoteTy _ ty)    = 
+       splitAlgTyConAppThroughNewTypes ty
+splitAlgTyConAppThroughNewTypes other       = Nothing

 \end{code}
 \end{code}