[project @ 2000-07-14 08:14:53 by simonpj]

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

diff --git a/ghc/compiler/codeGen/CgCase.lhs b/ghc/compiler/codeGen/CgCase.lhs
index a99a8fe..339569b 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.27 1999/04/27 12:34:52 simonm Exp $
+% $Id: CgCase.lhs,v 1.44 2000/07/14 08:14:53 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,9 +24,8 @@ 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,
                          bindNewPrimToAmode,
                          rebindToStack, getCAddrMode,
                          bindNewToReg, bindNewToTemp,
                          bindNewPrimToAmode,
                          rebindToStack, getCAddrMode,

@@ -40,7 +38,7 @@ import CgRetConv      ( dataReturnConvPrim, ctrlReturnConvAlg,
                          CtrlReturnConvention(..)
                        )
 import CgStackery      ( allocPrimStack, allocStackTop,
                          CtrlReturnConvention(..)
                        )
 import CgStackery      ( allocPrimStack, allocStackTop,

-                         deAllocStackTop, freeStackSlots
+                         deAllocStackTop, freeStackSlots, dataStackSlots

                        )
 import CgTailCall      ( tailCallFun )
 import CgUsages                ( getSpRelOffset, getRealSp )
                        )
 import CgTailCall      ( tailCallFun )
 import CgUsages                ( getSpRelOffset, getRealSp )

@@ -50,22 +48,20 @@ import CLabel               ( CLabel, mkVecTblLabel, mkReturnPtLabel,
                        )
 import ClosureInfo     ( mkLFArgument )
 import CmdLineOpts     ( opt_SccProfilingOn, opt_GranMacros )
                        )
 import ClosureInfo     ( mkLFArgument )
 import CmdLineOpts     ( opt_SccProfilingOn, opt_GranMacros )

-import CostCentre      ( CostCentre )
-import Id              ( Id, idPrimRep )
+import Id              ( Id, idPrimRep, isDeadBinder )

 import DataCon         ( DataCon, dataConTag, fIRST_TAG, ConTag,
 import DataCon         ( DataCon, dataConTag, fIRST_TAG, ConTag,

-                         isUnboxedTupleCon, dataConType )
+                         isUnboxedTupleCon )

 import VarSet          ( varSetElems )
 import VarSet          ( varSetElems )

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

 import PrimOp          ( primOpOutOfLine, PrimOp(..) )
 import PrimRep         ( getPrimRepSize, retPrimRepSize, PrimRep(..)
                        )
 import TyCon           ( TyCon, isEnumerationTyCon, isUnboxedTupleTyCon,
                          isNewTyCon, isAlgTyCon, isFunTyCon, isPrimTyCon,
 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, 
 import Type            ( Type, typePrimRep, splitAlgTyConApp, 

-                         splitTyConApp_maybe,
-                          splitFunTys, applyTys )
-import Unique           ( Unique, Uniquable(..), mkBuiltinUnique )
+                         splitTyConApp_maybe, repType )
+import Unique           ( Unique, Uniquable(..), mkPseudoUnique1 )

 import Maybes          ( maybeToBool )
 import Util
 import Outputable
 import Maybes          ( maybeToBool )
 import Util
 import Outputable

@@ -146,17 +142,22 @@ 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
+mkPseudoUnique1 to generate a temporary for the tag.  We can't use
+mkBuiltinUnique, because that occasionally clashes with some
+temporaries generated for _ccall_GC, amongst others (see CgExpr.lhs).
+

 \begin{code}
 \begin{code}

-cgCase (StgCon (PrimOp op) args res_ty)
+cgCase (StgPrimApp op args res_ty)

          live_in_whole_case live_in_alts bndr srt (StgAlgAlts ty alts deflt)
   | isEnumerationTyCon tycon
   = getArgAmodes args `thenFC` \ arg_amodes ->
 
     let tag_amode = case op of 
                        TagToEnumOp -> only arg_amodes
          live_in_whole_case live_in_alts bndr srt (StgAlgAlts ty alts deflt)
   | isEnumerationTyCon tycon
   = getArgAmodes args `thenFC` \ arg_amodes ->
 
     let tag_amode = case op of 
                        TagToEnumOp -> only arg_amodes

-                       _ -> CTemp (mkBuiltinUnique 1) IntRep
+                       _ -> CTemp (mkPseudoUnique1{-see above-} 1) IntRep

 
 

-       closure = CTableEntry (CLbl (mkClosureTblLabel tycon) PtrRep) tag_amode PtrRep
+       closure = CVal (CIndex (CLbl (mkClosureTblLabel tycon) PtrRep) tag_amode PtrRep) PtrRep

     in
 
     case op of {
     in
 
     case op of {

@@ -171,6 +172,7 @@ cgCase (StgCon (PrimOp op) args res_ty)
     }                                          `thenC`
 
        -- bind the default binder if necessary
     }                                          `thenC`
 
        -- 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 ->

@@ -193,7 +195,7 @@ cgCase (StgCon (PrimOp op) args res_ty)
 Special case #2: inline PrimOps.
 
 \begin{code}
 Special case #2: inline PrimOps.
 
 \begin{code}

-cgCase (StgCon (PrimOp op) args res_ty) 
+cgCase (StgPrimApp op args res_ty) 

        live_in_whole_case live_in_alts bndr srt alts
   | not (primOpOutOfLine op)
   =
        live_in_whole_case live_in_alts bndr srt alts
   | not (primOpOutOfLine op)
   =

@@ -238,10 +240,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}

@@ -437,9 +437,6 @@ 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
     buildContLivenessMask uniq         `thenFC` \ liveness_mask ->
 
     case alts of

@@ -448,9 +445,7 @@ cgEvalAlts cc_slot bndr srt alts
       (StgAlgAlts ty alts deflt) ->
 
           -- bind the default binder (it covers all the alternatives)
       (StgAlgAlts ty alts deflt) ->
 
           -- 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.

@@ -470,7 +465,7 @@ cgEvalAlts cc_slot bndr srt alts
        if is_alg && isUnboxedTupleTyCon spec_tycon then
            case alts of 
                [alt] -> let lbl = mkReturnInfoLabel uniq in
        if is_alg && isUnboxedTupleTyCon spec_tycon then
            case alts of 
                [alt] -> let lbl = mkReturnInfoLabel uniq in

-                        cgUnboxedTupleAlt lbl cc_slot True alt
+                        cgUnboxedTupleAlt uniq cc_slot True alt

                                `thenFC` \ abs_c ->
                         getSRTLabel `thenFC` \srt_label -> 
                         absC (CRetDirect uniq abs_c (srt_label, srt) 
                                `thenFC` \ abs_c ->
                         getSRTLabel `thenFC` \srt_label -> 
                         absC (CRetDirect uniq abs_c (srt_label, srt) 

@@ -505,17 +500,19 @@ cgEvalAlts cc_slot bndr srt alts
       -- primitive alts...
       (StgPrimAlts ty alts deflt) ->
 
       -- primitive alts...
       (StgPrimAlts ty alts deflt) ->
 

+       -- Restore the cost centre
+       restoreCurrentCostCentre cc_slot        `thenFC` \ cc_restore ->
+

        -- 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 ->
        -- 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 ->

-       restoreCurrentCostCentre cc_slot        `thenFC` \ cc_restore ->

        absC (CRetDirect uniq (cc_restore `mkAbsCStmts` abs_c) 
                        (srt_label,srt) liveness_mask)  `thenC`
 
        -- Return an amode for the block
        absC (CRetDirect uniq (cc_restore `mkAbsCStmts` abs_c) 
                        (srt_label,srt) liveness_mask)  `thenC`
 
        -- Return an amode for the block

-       returnFC (CaseAlts (CLbl (mkReturnPtLabel uniq) RetRep) Nothing)
+       returnFC (CaseAlts (CLbl (mkReturnInfoLabel uniq) RetRep) Nothing)

 \end{code}
 
 
 \end{code}
 
 

@@ -603,9 +600,10 @@ cgAlgDefault gc_flag is_fun uniq cc_slot must_label_branch
   =    -- We have arranged that Node points to the thing
     restoreCurrentCostCentre cc_slot `thenFC` \restore_cc ->
     getAbsC (absC restore_cc `thenC`
   =    -- 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`     
+             -- HWL: maybe need yield here
+             --(if emit_yield
+             --   then yield [node] True
+             --   else absC AbsCNop)                            `thenC`     

             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
             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

@@ -634,9 +632,10 @@ 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
             (case gc_flag of
                NoGC        -> mapFCs bindNewToTemp args `thenFC` \_ -> nopC
                GCMayHappen -> bindConArgs con args

@@ -654,7 +653,7 @@ cgAlgAlt gc_flag uniq cc_slot must_label_branch
     lbl = mkAltLabel uniq tag
 
 cgUnboxedTupleAlt
     lbl = mkAltLabel uniq tag
 
 cgUnboxedTupleAlt

-       :: CLabel                       -- label of the alternative
+       :: Unique                       -- unique for label of the alternative

        -> Maybe VirtualSpOffset        -- Restore cost centre
        -> Bool                         -- ctxt switch
        -> (DataCon, [Id], [Bool], StgExpr) -- alternative
        -> Maybe VirtualSpOffset        -- Restore cost centre
        -> Bool                         -- ctxt switch
        -> (DataCon, [Id], [Bool], StgExpr) -- alternative

@@ -668,9 +667,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 

@@ -752,14 +752,13 @@ cgPrimInlineAlts bndr ty alts deflt
 cgPrimEvalAlts bndr ty alts deflt
   = cgPrimAltsWithDefault bndr GCMayHappen (CReg reg) alts deflt [reg]
   where
 cgPrimEvalAlts bndr ty alts deflt
   = cgPrimAltsWithDefault bndr GCMayHappen (CReg reg) alts deflt [reg]
   where

-       reg = dataReturnConvPrim kind
+       reg  = WARN( case kind of { PtrRep -> True; other -> False }, text "cgPrimEE" <+> ppr bndr <+> ppr ty  )
+              dataReturnConvPrim kind

        kind = typePrimRep ty
 
 cgPrimAltsWithDefault bndr gc_flag scrutinee alts deflt regs
   =    -- first bind the default if necessary
        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`
+    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

@@ -862,19 +861,17 @@ 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 ->

+   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
    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

@@ -902,8 +899,6 @@ mkReturnVector :: Unique
 mkReturnVector uniq tagged_alt_absCs deflt_absC srt liveness ret_conv
   = getSRTLabel `thenFC` \srt_label ->
     let
 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...
      (return_vec_amode, vtbl_body) = case ret_conv of {
 
        -- might be a polymorphic case...

@@ -978,7 +973,7 @@ possibleHeapCheck
        -> Bool                         --  True <=> algebraic case
        -> [MagicId]                    --  live registers
        -> [(VirtualSpOffset,Int)]      --  stack slots to tag
        -> Bool                         --  True <=> algebraic case
        -> [MagicId]                    --  live registers
        -> [(VirtualSpOffset,Int)]      --  stack slots to tag

-       -> Maybe CLabel                 --  return address
+       -> Maybe Unique                 --  return address unique

        -> Code                         --  continuation
        -> Code
 
        -> Code                         --  continuation
        -> Code
 

@@ -988,41 +983,14 @@ possibleHeapCheck NoGC    _ _ tags lbl code
   = code
 \end{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 =
 \begin{code}
 getScrutineeTyCon :: Type -> Maybe TyCon
 getScrutineeTyCon ty =

-   case (splitTyConAppThroughNewTypes ty) of
+   case splitTyConApp_maybe (repType 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
        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
-
+               Just tc

 \end{code}
 \end{code}