[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 9eb6b22..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
 %
-% $Id: CgCase.lhs,v 1.32 1999/06/22 07:59:59 simonpj Exp $
+% $Id: CgCase.lhs,v 1.44 2000/07/14 08:14:53 simonpj Exp $
 %
 %********************************************************
 %*                                                     *
@@ -25,7 +25,7 @@ import AbsCUtils      ( mkAbstractCs, mkAbsCStmts, mkAlgAltsCSwitch,
                          getAmodeRep, nonemptyAbsC
                        )
 import CgUpdate                ( reserveSeqFrame )
-import CgBindery       ( getVolatileRegs, getArgAmodes, getArgAmode,
+import CgBindery       ( getVolatileRegs, getArgAmodes,
                          bindNewToReg, bindNewToTemp,
                          bindNewPrimToAmode,
                          rebindToStack, getCAddrMode,
@@ -48,22 +48,20 @@ import CLabel               ( CLabel, mkVecTblLabel, mkReturnPtLabel,
                        )
 import ClosureInfo     ( mkLFArgument )
 import CmdLineOpts     ( opt_SccProfilingOn, opt_GranMacros )
-import CostCentre      ( CostCentre )
-import CoreSyn         ( isDeadBinder )
-import Id              ( Id, idPrimRep )
+import Id              ( Id, idPrimRep, isDeadBinder )
 import DataCon         ( DataCon, dataConTag, fIRST_TAG, ConTag,
-                         isUnboxedTupleCon, dataConType )
+                         isUnboxedTupleCon )
 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,
-                         tyConDataCons, tyConFamilySize )
+                       )
 import Type            ( Type, typePrimRep, splitAlgTyConApp, 
-                         splitTyConApp_maybe, splitRepTyConApp_maybe )
-import Unique           ( Unique, Uniquable(..), mkBuiltinUnique )
+                         splitTyConApp_maybe, repType )
+import Unique           ( Unique, Uniquable(..), mkPseudoUnique1 )
 import Maybes          ( maybeToBool )
 import Util
 import Outputable
@@ -144,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).
 
+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}
-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
-                       _ -> 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 {
@@ -169,6 +172,7 @@ cgCase (StgCon (PrimOp op) args res_ty)
     }                                          `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 ->
@@ -191,7 +195,7 @@ cgCase (StgCon (PrimOp op) args res_ty)
 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)
   =
@@ -596,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`
-             (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
@@ -627,9 +632,10 @@ cgAlgAlt gc_flag uniq cc_slot must_label_branch
   = 
     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
@@ -661,9 +667,10 @@ cgUnboxedTupleAlt lbl cc_slot emit_yield (con,args,use_mask,rhs)
         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 
@@ -892,8 +899,6 @@ mkReturnVector :: Unique
 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...
@@ -981,7 +986,7 @@ possibleHeapCheck NoGC      _ _ tags lbl code
 \begin{code}
 getScrutineeTyCon :: Type -> Maybe TyCon
 getScrutineeTyCon ty =
-   case splitRepTyConApp_maybe ty of
+   case splitTyConApp_maybe (repType ty) of
        Nothing -> Nothing
        Just (tc,_) -> 
                if isFunTyCon tc  then Nothing else     -- not interested in funs