[project @ 2002-11-21 03:34:07 by chak]

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

diff --git a/ghc/compiler/codeGen/CgCase.lhs b/ghc/compiler/codeGen/CgCase.lhs
index aa09d5d..404e385 100644 (file)
--- a/ghc/compiler/codeGen/CgCase.lhs
+++ b/ghc/compiler/codeGen/CgCase.lhs
@@ -1,7 +1,7 @@
 %
 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
 %
 %
 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
 %

-% $Id: CgCase.lhs,v 1.28 1999/05/13 17:30:55 simonm Exp $
+% $Id: CgCase.lhs,v 1.60 2002/09/13 15:02:27 simonpj Exp $

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

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

-module CgCase (        cgCase, saveVolatileVarsAndRegs, 
-               restoreCurrentCostCentre, freeCostCentreSlot,
-               splitTyConAppThroughNewTypes ) where
+module CgCase (        cgCase, saveVolatileVarsAndRegs, restoreCurrentCostCentre
+       ) where

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

@@ -25,49 +24,39 @@ import AbsCSyn
 import AbsCUtils       ( mkAbstractCs, mkAbsCStmts, mkAlgAltsCSwitch,
                          getAmodeRep, nonemptyAbsC
                        )
 import AbsCUtils       ( mkAbstractCs, mkAbsCStmts, mkAlgAltsCSwitch,
                          getAmodeRep, nonemptyAbsC
                        )

-import CoreSyn         ( isDeadBinder )

 import CgUpdate                ( reserveSeqFrame )
 import CgUpdate                ( reserveSeqFrame )

-import CgBindery       ( getVolatileRegs, getArgAmodes, getArgAmode,
+import CgBindery       ( getVolatileRegs, getArgAmodes,

                          bindNewToReg, bindNewToTemp,
                          bindNewToReg, bindNewToTemp,

-                         bindNewPrimToAmode,
-                         rebindToStack, getCAddrMode,
-                         getCAddrModeAndInfo, getCAddrModeIfVolatile,
+                         bindNewPrimToAmode, getCAddrModeAndInfo,
+                         rebindToStack, getCAddrMode, getCAddrModeIfVolatile,

                          buildContLivenessMask, nukeDeadBindings,
                        )
 import CgCon           ( bindConArgs, bindUnboxedTupleComponents )
                          buildContLivenessMask, nukeDeadBindings,
                        )
 import CgCon           ( bindConArgs, bindUnboxedTupleComponents )

-import CgHeapery       ( altHeapCheck, yield )
+import CgHeapery       ( altHeapCheck )

 import CgRetConv       ( dataReturnConvPrim, ctrlReturnConvAlg,
                          CtrlReturnConvention(..)
                        )
 import CgStackery      ( allocPrimStack, allocStackTop,
 import CgRetConv       ( dataReturnConvPrim, ctrlReturnConvAlg,
                          CtrlReturnConvention(..)
                        )
 import CgStackery      ( allocPrimStack, allocStackTop,

-                         deAllocStackTop, freeStackSlots
+                         deAllocStackTop, freeStackSlots, dataStackSlots

                        )
 import CgTailCall      ( tailCallFun )
                        )
 import CgTailCall      ( tailCallFun )

-import CgUsages                ( getSpRelOffset, getRealSp )
-import CLabel          ( CLabel, mkVecTblLabel, mkReturnPtLabel, 
-                         mkDefaultLabel, mkAltLabel, mkReturnInfoLabel,
-                         mkErrorStdEntryLabel, mkClosureTblLabel
+import CgUsages                ( getSpRelOffset )
+import CLabel          ( mkVecTblLabel, mkClosureTblLabel,
+                         mkDefaultLabel, mkAltLabel, mkReturnInfoLabel

                        )
 import ClosureInfo     ( mkLFArgument )
                        )
 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 CmdLineOpts     ( opt_SccProfilingOn )
+import Id              ( Id, idPrimRep, isDeadBinder )
+import DataCon         ( DataCon, dataConTag, fIRST_TAG, ConTag )

 import VarSet          ( varSetElems )
 import VarSet          ( varSetElems )

-import Const           ( Con(..), Literal )
+import Literal         ( Literal )

 import PrimOp          ( primOpOutOfLine, PrimOp(..) )
 import PrimRep         ( getPrimRepSize, retPrimRepSize, PrimRep(..)
                        )
 import PrimOp          ( primOpOutOfLine, PrimOp(..) )
 import PrimRep         ( getPrimRepSize, retPrimRepSize, PrimRep(..)
                        )

-import TyCon           ( TyCon, isEnumerationTyCon, isUnboxedTupleTyCon,
-                         isNewTyCon, isAlgTyCon, isFunTyCon, isPrimTyCon,
-                         tyConDataCons, tyConFamilySize )
-import Type            ( Type, typePrimRep, splitAlgTyConApp, 
-                         splitTyConApp_maybe,
-                          splitFunTys, applyTys )
-import Unique           ( Unique, Uniquable(..), mkBuiltinUnique )
+import TyCon           ( isEnumerationTyCon, isUnboxedTupleTyCon, tyConPrimRep )
+import Unique           ( Unique, Uniquable(..), newTagUnique )

 import Maybes          ( maybeToBool )
 import Maybes          ( maybeToBool )

-import Util
+import Util            ( only )

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

@@ -146,31 +135,41 @@ which generates no code for the primop, unless x is used in the
 alternatives (in which case we lookup the tag in the relevant closure
 table to get the closure).
 
 alternatives (in which case we lookup the tag in the relevant closure
 table to get the closure).
 

+Being a bit short of uniques for temporary variables here, we use
+newTagUnique to generate a new unique from the case binder.  The case
+binder's unique will presumably have the 'c' tag (generated by
+CoreToStg), so we just change its tag to 'C' (for 'case') to ensure it
+doesn't clash with anything else.
+

 \begin{code}
 \begin{code}

-cgCase (StgCon (PrimOp op) args res_ty)
-         live_in_whole_case live_in_alts bndr srt (StgAlgAlts ty alts deflt)
+cgCase (StgOpApp op args _)
+       live_in_whole_case live_in_alts bndr srt (StgAlgAlts (Just tycon) alts deflt)

   | isEnumerationTyCon tycon
   = getArgAmodes args `thenFC` \ arg_amodes ->
 
   | isEnumerationTyCon tycon
   = getArgAmodes args `thenFC` \ arg_amodes ->
 

-    let tag_amode = case op of 
-                       TagToEnumOp -> only arg_amodes
-                       _ -> CTemp (mkBuiltinUnique 1) IntRep
-
-       closure = CTableEntry (CLbl (mkClosureTblLabel tycon) PtrRep) tag_amode PtrRep
-    in
-

     case op of {
     case op of {

-       TagToEnumOp -> nopC;  -- no code!
-
-       _ ->    -- Perform the operation
-              getVolatileRegs live_in_alts     `thenFC` \ vol_regs ->
+       StgPrimOp TagToEnumOp   -- No code!
+          -> returnFC (only arg_amodes) ;
+
+       _  ->           -- Perform the operation
+             let
+               tag_amode = CTemp (newTagUnique (getUnique bndr) 'C') IntRep
+             in
+             getVolatileRegs live_in_alts                      `thenFC` \ vol_regs ->
+             absC (COpStmt [tag_amode] op arg_amodes vol_regs)
+                                                               `thenC`
+                               -- NB: no liveness arg
+             returnFC tag_amode
+    }                                          `thenFC` \ tag_amode ->

 
 

-              absC (COpStmt [tag_amode] op
-                arg_amodes -- note: no liveness arg
-                vol_regs)
-    }                                          `thenC`
+    let
+       closure = CVal (CIndex (CLbl (mkClosureTblLabel tycon) PtrRep) 
+                              tag_amode PtrRep) 
+                      PtrRep
+    in

 
 

-       -- bind the default binder if necessary
+       -- Bind the default binder if necessary
+       -- The deadness info is set by StgVarInfo

     (if (isDeadBinder bndr)
        then nopC
        else bindNewToTemp bndr                 `thenFC` \ bndr_amode ->
     (if (isDeadBinder bndr)
        then nopC
        else bindNewToTemp bndr                 `thenFC` \ bndr_amode ->

@@ -178,39 +177,54 @@ cgCase (StgCon (PrimOp op) args res_ty)
                                                `thenC`
 
        -- compile the alts
                                                `thenC`
 
        -- compile the alts

-    cgAlgAlts NoGC uniq Nothing{-cc_slot-} False{-no semi-tagging-}
+    cgAlgAlts NoGC (getUnique bndr) Nothing{-cc_slot-} 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)
                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)

+\end{code}

 
 

-   where
-       (Just (tycon,_)) = splitTyConApp_maybe res_ty
-       uniq = getUnique bndr
+Special case #2: case of literal.
+
+\begin{code}
+cgCase (StgLit lit) live_in_whole_case live_in_alts bndr srt alts =
+  absC (CAssign (CTemp (getUnique bndr) (idPrimRep bndr)) (CLit lit)) `thenC`
+  case alts of 
+      StgPrimAlts tycon alts deflt -> cgPrimInlineAlts bndr tycon alts deflt
+      other -> pprPanic "cgCase: case of literal has strange alts" (pprStgAlts alts)

 \end{code}
 
 \end{code}
 

-Special case #2: inline PrimOps.
+Special case #3: inline PrimOps.

 
 \begin{code}
 
 \begin{code}

-cgCase (StgCon (PrimOp op) args res_ty) 
-       live_in_whole_case live_in_alts bndr srt alts
-  | not (primOpOutOfLine op)
+cgCase (StgOpApp op@(StgPrimOp primop) args _) 
+       live_in_whole_case live_in_alts bndr srt alts
+  | not (primOpOutOfLine primop)

   =
        -- Get amodes for the arguments and results
     getArgAmodes args                  `thenFC` \ arg_amodes ->
   =
        -- Get amodes for the arguments and results
     getArgAmodes args                  `thenFC` \ arg_amodes ->

-    let
-       result_amodes = getPrimAppResultAmodes (getUnique bndr) alts
-    in
-       -- Perform the operation

     getVolatileRegs live_in_alts        `thenFC` \ vol_regs ->
 
     getVolatileRegs live_in_alts        `thenFC` \ vol_regs ->
 

-    absC (COpStmt result_amodes op
-                arg_amodes -- note: no liveness arg
-                vol_regs)              `thenC`
-
-       -- Scrutinise the result
-    cgInlineAlts bndr alts
+    case alts of 
+      StgPrimAlts tycon alts deflt     -- PRIMITIVE ALTS
+       -> absC (COpStmt [CTemp (getUnique bndr) (tyConPrimRep tycon)]
+                        op
+                        arg_amodes     -- note: no liveness arg
+                        vol_regs)              `thenC`
+          cgPrimInlineAlts bndr tycon alts deflt
+
+      StgAlgAlts (Just tycon) [(_, args, _, rhs)] StgNoDefault 
+       |  isUnboxedTupleTyCon tycon    -- UNBOXED TUPLE ALTS
+       ->      -- no heap check, no yield, just get in there and do it.
+          absC (COpStmt [ CTemp (getUnique arg) (idPrimRep arg) | arg <- args ]
+                        op
+                        arg_amodes      -- note: no liveness arg
+                        vol_regs)              `thenC`
+          mapFCs bindNewToTemp args `thenFC` \ _ ->
+          cgExpr rhs
+
+      other -> pprPanic "cgCase: case of primop has strange alts" (pprStgAlts alts)

 \end{code}
 
 TODO: Case-of-case of primop can probably be done inline too (but
 \end{code}
 
 TODO: Case-of-case of primop can probably be done inline too (but

@@ -227,7 +241,7 @@ eliminate a heap check altogether.
 
 \begin{code}
 cgCase (StgApp v []) live_in_whole_case live_in_alts bndr srt
 
 \begin{code}
 cgCase (StgApp v []) live_in_whole_case live_in_alts bndr srt

-                       (StgPrimAlts ty alts deflt)
+                       (StgPrimAlts tycon alts deflt)

 
   = 
     getCAddrMode v             `thenFC` \amode ->
 
   = 
     getCAddrMode v             `thenFC` \amode ->

@@ -238,10 +252,8 @@ cgCase (StgApp v []) live_in_whole_case live_in_alts bndr srt
        two bindings pointing at the same stack locn doesn't work (it
        confuses nukeDeadBindings).  Hence, use a new temp.
     -}
        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`
+    bindNewToTemp bndr                 `thenFC`  \deflt_amode ->
+    absC (CAssign deflt_amode amode)   `thenC`

 
     cgPrimAlts NoGC amode alts deflt []
 \end{code}
 
     cgPrimAlts NoGC amode alts deflt []
 \end{code}

@@ -252,12 +264,11 @@ we can reuse/trim the stack slot holding the variable (if it is in one).
 
 \begin{code}
 cgCase (StgApp fun args)
 
 \begin{code}
 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 ->
+       live_in_whole_case live_in_alts bndr srt alts
+  = getCAddrModeAndInfo fun                    `thenFC` \ (fun', fun_amode, lf_info) ->
+    getArgAmodes args                          `thenFC` \ arg_amodes ->

 
 

-       -- Squish the environment
+       -- Squish the environment

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

@@ -265,24 +276,12 @@ cgCase (StgApp fun args)
     allocStackTop retPrimRepSize       `thenFC` \_ ->
 
     forkEval alts_eob_info nopC (
     allocStackTop retPrimRepSize       `thenFC` \_ ->
 
     forkEval alts_eob_info nopC (

-               deAllocStackTop retPrimRepSize `thenFC` \_ ->
-               cgEvalAlts maybe_cc_slot bndr srt alts) 
+            deAllocStackTop retPrimRepSize `thenFC` \_ ->
+            cgEvalAlts maybe_cc_slot bndr srt alts) 

                                         `thenFC` \ scrut_eob_info ->
 
                                         `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
+    setEndOfBlockInfo (maybeReserveSeqFrame alts scrut_eob_info)       $
+    tailCallFun fun' fun_amode lf_info arg_amodes save_assts

 \end{code}
 
 Note about return addresses: we *always* push a return address, even
 \end{code}
 
 Note about return addresses: we *always* push a return address, even

@@ -311,26 +310,15 @@ cgCase expr live_in_whole_case live_in_alts bndr srt alts
 
     -- generate code for the alts
     forkEval alts_eob_info
 
     -- generate code for the alts
     forkEval alts_eob_info

-       (
-        nukeDeadBindings live_in_alts `thenC` 
+       (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 ->
 
         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)
-
-  where
-     not_con_ty = case (getScrutineeTyCon (alts_ty alts)) of
-                       Just _ -> False
-                       other  -> True
+    setEndOfBlockInfo (maybeReserveSeqFrame alts scrut_eob_info) $
+    cgExpr expr

 \end{code}
 
 There's a lot of machinery going on behind the scenes to manage the
 \end{code}
 
 There's a lot of machinery going on behind the scenes to manage the

@@ -368,52 +356,11 @@ don't follow the layout of closures when we're profiling.  The CCS
 could be anywhere within the record).
 
 \begin{code}
 could be anywhere within the record).
 
 \begin{code}

-alts_ty (StgAlgAlts ty _ _) = ty
-alts_ty (StgPrimAlts ty _ _) = ty
-\end{code}
-
-%************************************************************************
-%*                                                                     *
-\subsection[CgCase-primops]{Primitive applications}
-%*                                                                     *
-%************************************************************************
-
-Get result amodes for a primitive operation, in the case wher GC can't happen.
-The  amodes are returned in canonical order, ready for the prim-op!
-
-       Alg case: temporaries named as in the alternatives,
-                 plus (CTemp u) for the tag (if needed)
-       Prim case: (CTemp u)
-
-This is all disgusting, because these amodes must be consistent with those
-invented by CgAlgAlts.
-
-\begin{code}
-getPrimAppResultAmodes
-       :: Unique
-       -> StgCaseAlts
-       -> [CAddrMode]
-
-getPrimAppResultAmodes uniq (StgAlgAlts ty alts some_default)
-
-  | 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"
-
-  | otherwise = panic ("getPrimAppResultAmodes: case of primop has strange type: " ++ showSDoc (ppr ty))
-
-  where (tycon, _, _) = splitAlgTyConApp ty
-
--- The situation is simpler for primitive results, because there is only
--- one!
-
-getPrimAppResultAmodes uniq (StgPrimAlts ty _ _)
-  = [CTemp uniq (typePrimRep ty)]
+-- We need to reserve a seq frame for a polymorphic case
+maybeReserveSeqFrame (StgAlgAlts Nothing _ _) scrut_eob_info = reserveSeqFrame scrut_eob_info
+maybeReserveSeqFrame other                   scrut_eob_info = scrut_eob_info

 \end{code}
 
 \end{code}
 

-

 %************************************************************************
 %*                                                                     *
 \subsection[CgCase-alts]{Alternatives}
 %************************************************************************
 %*                                                                     *
 \subsection[CgCase-alts]{Alternatives}

@@ -437,20 +384,15 @@ cgEvalAlts cc_slot bndr srt alts
   =    
     let uniq = getUnique bndr in
 
   =    
     let uniq = getUnique bndr in
 

-    -- get the stack liveness for the info table (after the CC slot has
-    -- been freed - this is important).
-    freeCostCentreSlot cc_slot         `thenC`

     buildContLivenessMask uniq         `thenFC` \ liveness_mask ->
 
     case alts of
 
       -- algebraic alts ...
     buildContLivenessMask uniq         `thenFC` \ liveness_mask ->
 
     case alts of
 
       -- algebraic alts ...

-      (StgAlgAlts ty alts deflt) ->
+      StgAlgAlts maybe_tycon alts deflt ->

 
           -- bind the default binder (it covers all the alternatives)
 
           -- bind the default binder (it covers all the alternatives)

-       (if (isDeadBinder bndr)
-               then nopC
-               else bindNewToReg bndr node mkLFArgument) `thenC`
+       bindNewToReg bndr node mkLFArgument      `thenC`

 
        -- Generate sequel info for use downstream
        -- At the moment, we only do it if the type is vector-returnable.
 
        -- Generate sequel info for use downstream
        -- At the moment, we only do it if the type is vector-returnable.

@@ -461,22 +403,26 @@ cgEvalAlts cc_slot bndr srt alts
        --
        -- 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     tycon_info      = getScrutineeTyCon ty
-               is_alg          = maybeToBool tycon_info
-               Just spec_tycon = tycon_info
+       let     is_alg          = maybeToBool maybe_tycon
+               Just spec_tycon = maybe_tycon

        in
 
        in
 

-       -- deal with the unboxed tuple case
+       -- Deal with the unboxed tuple case

        if is_alg && isUnboxedTupleTyCon spec_tycon then
        if is_alg && isUnboxedTupleTyCon spec_tycon then

-           case alts of 
-               [alt] -> let lbl = mkReturnInfoLabel uniq in
-                        cgUnboxedTupleAlt uniq cc_slot 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"
+               -- By now, the simplifier should have have turned it
+               -- into         case e of (# a,b #) -> e
+               -- There shouldn't be a 
+               --              case e of DEFAULT -> e
+           ASSERT2( case (alts, deflt) of { ([_],StgNoDefault) -> True; other -> False },
+                    text "cgEvalAlts: dodgy case of unboxed tuple type" )
+           let
+               alt = head alts
+               lbl = mkReturnInfoLabel uniq
+           in
+           cgUnboxedTupleAlt uniq cc_slot True alt             `thenFC` \ abs_c ->
+           getSRTInfo srt                                      `thenFC` \ srt_info -> 
+           absC (CRetDirect uniq abs_c srt_info liveness_mask) `thenC`
+           returnFC (CaseAlts (CLbl lbl RetRep) Nothing)

 
        -- normal algebraic (or polymorphic) case alternatives
        else let
 
        -- normal algebraic (or polymorphic) case alternatives
        else let

@@ -503,54 +449,30 @@ cgEvalAlts cc_slot bndr srt alts
        returnFC (CaseAlts return_vec semi_tagged_stuff)
 
       -- primitive alts...
        returnFC (CaseAlts return_vec semi_tagged_stuff)
 
       -- primitive alts...

-      (StgPrimAlts ty alts deflt) ->
+      StgPrimAlts tycon alts deflt ->
+
+       -- Restore the cost centre
+       restoreCurrentCostCentre cc_slot                `thenFC` \ cc_restore ->

 
        -- Generate the switch
 
        -- Generate the switch

-       getAbsC (cgPrimEvalAlts bndr ty alts deflt)     `thenFC` \ abs_c ->
+       getAbsC (cgPrimEvalAlts bndr tycon alts deflt)  `thenFC` \ abs_c ->

 
        -- Generate the labelled block, starting with restore-cost-centre
 
        -- Generate the labelled block, starting with restore-cost-centre

-       getSRTLabel                                     `thenFC` \srt_label ->
-       restoreCurrentCostCentre cc_slot        `thenFC` \ cc_restore ->
+       getSRTInfo srt                                  `thenFC` \srt_info ->

        absC (CRetDirect uniq (cc_restore `mkAbsCStmts` abs_c) 
        absC (CRetDirect uniq (cc_restore `mkAbsCStmts` abs_c) 

-                       (srt_label,srt) liveness_mask)  `thenC`
+                        srt_info liveness_mask)        `thenC`

 
        -- Return an amode for the block
        returnFC (CaseAlts (CLbl (mkReturnInfoLabel uniq) RetRep) Nothing)
 \end{code}
 
 
 
        -- Return an amode for the block
        returnFC (CaseAlts (CLbl (mkReturnInfoLabel uniq) RetRep) Nothing)
 \end{code}
 
 

-\begin{code}
-cgInlineAlts :: Id
-            -> StgCaseAlts
-            -> Code
-\end{code}
-

 HWL comment on {\em GrAnSim\/}  (adding GRAN_YIELDs for context switch): If
 we  do  an inlining of the  case  no separate  functions  for returning are
 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.
 
 HWL comment on {\em GrAnSim\/}  (adding GRAN_YIELDs for context switch): If
 we  do  an inlining of the  case  no separate  functions  for returning are
 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.
 

-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}
-
-Third (real) case: primitive result type.
-
-\begin{code}
-cgInlineAlts bndr (StgPrimAlts ty alts deflt)
-  = cgPrimInlineAlts bndr ty alts deflt
-\end{code}
-

 %************************************************************************
 %*                                                                     *
 \subsection[CgCase-alg-alts]{Algebraic alternatives}
 %************************************************************************
 %*                                                                     *
 \subsection[CgCase-alg-alts]{Algebraic alternatives}

@@ -578,11 +500,11 @@ cgAlgAlts :: GCFlag
                    AbstractC                   -- The default case
             )
 
                    AbstractC                   -- The default case
             )
 

-cgAlgAlts gc_flag uniq restore_cc must_label_branches is_fun alts deflt
+cgAlgAlts gc_flag uniq restore_cc must_label_branches is_poly 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)

-            (cgAlgDefault gc_flag is_fun uniq restore_cc must_label_branches deflt emit_yield)
+            (cgAlgDefault gc_flag is_poly uniq restore_cc must_label_branches deflt emit_yield)

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

@@ -593,20 +515,21 @@ cgAlgDefault :: GCFlag
             -> Bool
             -> FCode AbstractC         -- output
 
             -> Bool
             -> FCode AbstractC         -- output
 

-cgAlgDefault gc_flag is_fun uniq cc_slot must_label_branch StgNoDefault _
+cgAlgDefault gc_flag is_poly uniq cc_slot must_label_branch StgNoDefault _

   = returnFC AbsCNop
 
   = returnFC AbsCNop
 

-cgAlgDefault gc_flag is_fun uniq cc_slot must_label_branch
+cgAlgDefault gc_flag is_poly uniq cc_slot must_label_branch

             (StgBindDefault rhs)
           emit_yield{-should a yield macro be emitted?-}
 
   =    -- We have arranged that Node points to the thing
     restoreCurrentCostCentre cc_slot `thenFC` \restore_cc ->
     getAbsC (absC restore_cc `thenC`
             (StgBindDefault rhs)
           emit_yield{-should a yield macro be emitted?-}
 
   =    -- We have arranged that Node points to the thing
     restoreCurrentCostCentre cc_slot `thenFC` \restore_cc ->
     getAbsC (absC restore_cc `thenC`

-             (if opt_GranMacros && emit_yield
-                then yield [node] False
-                else absC AbsCNop)                            `thenC`     
-            possibleHeapCheck gc_flag is_fun [node] [] Nothing (cgExpr rhs)
+             -- HWL: maybe need yield here
+             --(if emit_yield
+             --   then yield [node] True
+             --   else absC AbsCNop)                            `thenC`     
+            algAltHeapCheck gc_flag is_poly [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.
        -- 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.

@@ -634,14 +557,15 @@ cgAlgAlt gc_flag uniq cc_slot must_label_branch
   = 
     restoreCurrentCostCentre cc_slot `thenFC` \restore_cc ->
     getAbsC (absC restore_cc `thenC`
   = 
     restoreCurrentCostCentre cc_slot `thenFC` \restore_cc ->
     getAbsC (absC restore_cc `thenC`

-            (if opt_GranMacros && emit_yield
-               then yield [node] True          -- XXX live regs wrong
-               else absC AbsCNop)                               `thenC`     
+             -- HWL: maybe need yield here
+            -- (if 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`
             (case gc_flag of
                NoGC        -> mapFCs bindNewToTemp args `thenFC` \_ -> nopC
                GCMayHappen -> bindConArgs con args
             )  `thenC`

-            possibleHeapCheck gc_flag False [node] [] Nothing (
+            algAltHeapCheck gc_flag False [node] [] Nothing (

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

@@ -668,9 +592,10 @@ cgUnboxedTupleAlt lbl cc_slot emit_yield (con,args,use_mask,rhs)
         restoreCurrentCostCentre cc_slot `thenFC` \restore_cc ->
        absC restore_cc `thenC`
 
         restoreCurrentCostCentre cc_slot `thenFC` \restore_cc ->
        absC restore_cc `thenC`
 

-       (if opt_GranMacros && emit_yield
-           then yield live_regs True           -- XXX live regs wrong?
-           else absC AbsCNop)                         `thenC`     
+        -- HWL: maybe need yield here
+       -- (if 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 
        let 
              -- ToDo: could maybe use Nothing here if stack_res is False
              -- since the heap-check can just return to the top of the 

@@ -682,7 +607,7 @@ cgUnboxedTupleAlt lbl cc_slot emit_yield (con,args,use_mask,rhs)
        freeStackSlots (map fst tags)           `thenC`
 
        -- generate a heap check if necessary
        freeStackSlots (map fst tags)           `thenC`
 
        -- generate a heap check if necessary

-       possibleHeapCheck GCMayHappen False live_regs tags ret_addr (
+       primAltHeapCheck GCMayHappen live_regs tags ret_addr (

 
        -- and finally the code for the alternative
        cgExpr rhs)
 
        -- and finally the code for the alternative
        cgExpr rhs)

@@ -713,14 +638,14 @@ cgSemiTaggedAlts binder alts deflt
 
     st_deflt (StgBindDefault _)
       = Just (Just binder,
 
     st_deflt (StgBindDefault _)
       = Just (Just binder,

-             (CCallProfCtrMacro SLIT("RET_SEMI_BY_DEFAULT") [], -- ToDo: monadise?
+             (CCallProfCtrMacro FSLIT("RET_SEMI_BY_DEFAULT") [], -- ToDo: monadise?

               mkDefaultLabel uniq)
             )
 
     st_alt (con, args, use_mask, _)
       =  -- Ha!  Nothing to do; Node already points to the thing
         (con_tag,
               mkDefaultLabel uniq)
             )
 
     st_alt (con, args, use_mask, _)
       =  -- Ha!  Nothing to do; Node already points to the thing
         (con_tag,

-          (CCallProfCtrMacro SLIT("RET_SEMI_IN_HEAP") -- ToDo: monadise?
+          (CCallProfCtrMacro FSLIT("RET_SEMI_IN_HEAP") -- ToDo: monadise?

                [mkIntCLit (length args)], -- how big the thing in the heap is
             join_label)
            )
                [mkIntCLit (length args)], -- how big the thing in the heap is
             join_label)
            )

@@ -743,23 +668,21 @@ 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}

-cgPrimInlineAlts bndr ty alts deflt
+cgPrimInlineAlts bndr tycon alts deflt

   = cgPrimAltsWithDefault bndr NoGC (CTemp uniq kind) alts deflt []
   where
        uniq = getUnique bndr
   = cgPrimAltsWithDefault bndr NoGC (CTemp uniq kind) alts deflt []
   where
        uniq = getUnique bndr

-       kind = typePrimRep ty
+       kind = tyConPrimRep tycon

 
 

-cgPrimEvalAlts bndr ty alts deflt
+cgPrimEvalAlts bndr tycon alts deflt

   = cgPrimAltsWithDefault bndr GCMayHappen (CReg reg) alts deflt [reg]
   where
   = cgPrimAltsWithDefault bndr GCMayHappen (CReg reg) alts deflt [reg]
   where

-       reg = dataReturnConvPrim kind
-       kind = typePrimRep ty
+       reg  = dataReturnConvPrim kind
+       kind = tyConPrimRep tycon

 
 cgPrimAltsWithDefault bndr gc_flag scrutinee alts deflt regs
   =    -- first bind the default if necessary
 
 cgPrimAltsWithDefault bndr gc_flag scrutinee alts deflt regs
   =    -- first bind the default if necessary

-    (if isDeadBinder bndr 
-       then nopC
-       else bindNewPrimToAmode bndr scrutinee)         `thenC`
+    bindNewPrimToAmode bndr scrutinee          `thenC`

     cgPrimAlts gc_flag scrutinee alts deflt regs
 
 cgPrimAlts gc_flag scrutinee alts deflt regs
     cgPrimAlts gc_flag scrutinee alts deflt regs
 
 cgPrimAlts gc_flag scrutinee alts deflt regs

@@ -780,7 +703,7 @@ 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 regs [] Nothing (cgExpr rhs)
+    rhs_code = primAltHeapCheck gc_flag regs [] Nothing (cgExpr rhs)

 
 cgPrimDefault :: GCFlag
              -> [MagicId]              -- live registers
 
 cgPrimDefault :: GCFlag
              -> [MagicId]              -- live registers

@@ -791,7 +714,7 @@ cgPrimDefault gc_flag regs StgNoDefault
   = panic "cgPrimDefault: No default in prim case"
 
 cgPrimDefault gc_flag regs (StgBindDefault rhs)
   = panic "cgPrimDefault: No default in prim case"
 
 cgPrimDefault gc_flag regs (StgBindDefault rhs)

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

 \end{code}
 
 
 \end{code}
 
 

@@ -862,22 +785,20 @@ saveCurrentCostCentre
   = if not opt_SccProfilingOn then
        returnFC (Nothing, AbsCNop)
     else
   = if not opt_SccProfilingOn then
        returnFC (Nothing, AbsCNop)
     else

-       allocPrimStack (getPrimRepSize CostCentreRep)  `thenFC` \ slot ->
+       allocPrimStack (getPrimRepSize CostCentreRep) `thenFC` \ slot ->
+       dataStackSlots [slot]                         `thenC`

        getSpRelOffset slot                           `thenFC` \ sp_rel ->
        returnFC (Just slot,
                  CAssign (CVal sp_rel CostCentreRep) (CReg CurCostCentre))
 
        getSpRelOffset slot                           `thenFC` \ sp_rel ->
        returnFC (Just slot,
                  CAssign (CVal sp_rel CostCentreRep) (CReg CurCostCentre))
 

-freeCostCentreSlot :: Maybe VirtualSpOffset -> Code
-freeCostCentreSlot Nothing = nopC
-freeCostCentreSlot (Just slot) = freeStackSlots [slot]
-

 restoreCurrentCostCentre :: Maybe VirtualSpOffset -> FCode AbstractC
 restoreCurrentCostCentre Nothing = returnFC AbsCNop
 restoreCurrentCostCentre (Just slot)
  = getSpRelOffset slot                          `thenFC` \ sp_rel ->
 restoreCurrentCostCentre :: Maybe VirtualSpOffset -> FCode AbstractC
 restoreCurrentCostCentre Nothing = returnFC AbsCNop
 restoreCurrentCostCentre (Just slot)
  = getSpRelOffset slot                          `thenFC` \ sp_rel ->

-   returnFC (CCallProfCCMacro SLIT("RESTORE_CCCS") [CVal sp_rel CostCentreRep])
+   freeStackSlots [slot]                        `thenC`
+   returnFC (CCallProfCCMacro FSLIT("RESTORE_CCCS") [CVal sp_rel CostCentreRep])

     -- we use the RESTORE_CCCS macro, rather than just
     -- we use the RESTORE_CCCS macro, rather than just

-    -- assigning into CurCostCentre, in case RESTORE_CCC
+    -- assigning into CurCostCentre, in case RESTORE_CCCS

     -- has some sanity-checking in it.
 \end{code}
 
     -- has some sanity-checking in it.
 \end{code}
 

@@ -900,17 +821,15 @@ mkReturnVector :: Unique
               -> FCode CAddrMode
 
 mkReturnVector uniq tagged_alt_absCs deflt_absC srt liveness ret_conv
               -> FCode CAddrMode
 
 mkReturnVector uniq tagged_alt_absCs deflt_absC srt liveness ret_conv

-  = getSRTLabel `thenFC` \srt_label ->
+  = getSRTInfo srt             `thenFC` \ srt_info ->

     let
     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,
      (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));
+        absC (CRetDirect uniq deflt_absC srt_info liveness));

 
       UnvectoredReturn n ->
         -- find the tag explicitly rather than using tag_reg for now.
 
       UnvectoredReturn n ->
         -- find the tag explicitly rather than using tag_reg for now.

@@ -922,7 +841,7 @@ mkReturnVector uniq tagged_alt_absCs deflt_absC srt liveness ret_conv
        (CLbl ret_label RetRep,
         absC (CRetDirect uniq 
                            (mkAlgAltsCSwitch tag tagged_alt_absCs deflt_absC)
        (CLbl ret_label RetRep,
         absC (CRetDirect uniq 
                            (mkAlgAltsCSwitch tag tagged_alt_absCs deflt_absC)

-                           (srt_label, srt)
+                           srt_info

                            liveness));
 
       VectoredReturn table_size ->
                            liveness));
 
       VectoredReturn table_size ->

@@ -930,9 +849,7 @@ mkReturnVector uniq tagged_alt_absCs deflt_absC srt liveness ret_conv
          (vector_table, alts_absC) = 
            unzip (map mk_vector_entry [fIRST_TAG .. (table_size+fIRST_TAG-1)])
 
          (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
+         ret_vector = CRetVector vtbl_label vector_table srt_info liveness

        in
        (CLbl vtbl_label DataPtrRep, 
         -- alts come first, because we don't want to declare all the symbols
        in
        (CLbl vtbl_label DataPtrRep, 
         -- alts come first, because we don't want to declare all the symbols

@@ -951,7 +868,7 @@ mkReturnVector uniq tagged_alt_absCs deflt_absC srt liveness ret_conv
     deflt_lbl = 
        case nonemptyAbsC deflt_absC of
                 -- the simplifier might have eliminated a case
     deflt_lbl = 
        case nonemptyAbsC deflt_absC of
                 -- the simplifier might have eliminated a case

-          Nothing -> CLbl mkErrorStdEntryLabel CodePtrRep 
+          Nothing -> mkIntCLit 0 -- CLbl mkErrorStdEntryLabel CodePtrRep 

           Just absC@(CCodeBlock lbl _) -> CLbl lbl CodePtrRep
 
     mk_vector_entry :: ConTag -> (CAddrMode, AbstractC)
           Just absC@(CCodeBlock lbl _) -> CLbl lbl CodePtrRep
 
     mk_vector_entry :: ConTag -> (CAddrMode, AbstractC)

@@ -973,56 +890,22 @@ heap check or not.  These heap checks are always in a case
 alternative, so we use altHeapCheck.
 
 \begin{code}
 alternative, so we use altHeapCheck.
 
 \begin{code}

-possibleHeapCheck 
+algAltHeapCheck 

        :: GCFlag 
        :: GCFlag 

-       -> Bool                         --  True <=> algebraic case
+       -> Bool                         --  True <=> polymorphic case

        -> [MagicId]                    --  live registers
        -> [(VirtualSpOffset,Int)]      --  stack slots to tag
        -> Maybe Unique                 --  return address unique
        -> Code                         --  continuation
        -> Code
 
        -> [MagicId]                    --  live registers
        -> [(VirtualSpOffset,Int)]      --  stack slots to tag
        -> Maybe Unique                 --  return address unique
        -> Code                         --  continuation
        -> Code
 

-possibleHeapCheck GCMayHappen is_alg regs tags lbl code 
-  = altHeapCheck is_alg regs tags AbsCNop lbl code
-possibleHeapCheck NoGC _ _ tags lbl code 
+algAltHeapCheck GCMayHappen is_poly regs tags lbl code 
+  = altHeapCheck is_poly False regs tags AbsCNop lbl code
+algAltHeapCheck NoGC   _ _ tags lbl code 

   = code
   = code

-\end{code}
-
-splitTyConAppThroughNewTypes is like splitTyConApp_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}
-getScrutineeTyCon :: Type -> Maybe TyCon
-getScrutineeTyCon ty =
-   case (splitTyConAppThroughNewTypes ty) of
-       Nothing -> Nothing
-       Just (tc,_) -> 
-               if isFunTyCon tc  then Nothing else     -- not interested in funs
-               if isPrimTyCon tc then Just tc else     -- return primitive tycons
-                       -- otherwise (algebraic tycons) check the no. of constructors
-               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
-
-splitTyConAppThroughNewTypes  :: Type -> Maybe (TyCon, [Type])
-splitTyConAppThroughNewTypes ty
-  = case splitTyConApp_maybe ty of
-      Just (tc, tys)
-       | isNewTyCon tc ->  splitTyConAppThroughNewTypes ty
-       | otherwise     ->  Just (tc, tys)
-       where
-         ([ty], _) = splitFunTys (applyTys (dataConType (head (tyConDataCons tc))) tys)
-
-      other  -> Nothing

 
 

+primAltHeapCheck GCMayHappen regs tags lbl code
+  = altHeapCheck False True regs tags AbsCNop lbl code
+primAltHeapCheck NoGC _ _ _ code 
+  = code

 \end{code}
 \end{code}