[project @ 2000-11-10 15:12:50 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 d64755b..07b1db4 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.42 2000/05/25 12:41:15 simonpj Exp $
+% $Id: CgCase.lhs,v 1.49 2000/11/10 15:12:51 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,
@@ -33,7 +33,7 @@ import CgBindery      ( getVolatileRegs, getArgAmodes, getArgAmode,
                          buildContLivenessMask, nukeDeadBindings,
                        )
 import CgCon           ( bindConArgs, bindUnboxedTupleComponents )
-import CgHeapery       ( altHeapCheck, yield )
+import CgHeapery       ( altHeapCheck )
 import CgRetConv       ( dataReturnConvPrim, ctrlReturnConvAlg,
                          CtrlReturnConvention(..)
                        )
@@ -41,14 +41,12 @@ import CgStackery   ( allocPrimStack, allocStackTop,
                          deAllocStackTop, freeStackSlots, dataStackSlots
                        )
 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 CmdLineOpts     ( opt_SccProfilingOn, opt_GranMacros )
-import CostCentre      ( CostCentre )
+import CmdLineOpts     ( opt_SccProfilingOn )
 import Id              ( Id, idPrimRep, isDeadBinder )
 import DataCon         ( DataCon, dataConTag, fIRST_TAG, ConTag,
                          isUnboxedTupleCon )
@@ -58,12 +56,11 @@ import PrimOp               ( primOpOutOfLine, PrimOp(..) )
 import PrimRep         ( getPrimRepSize, retPrimRepSize, PrimRep(..)
                        )
 import TyCon           ( TyCon, isEnumerationTyCon, isUnboxedTupleTyCon,
-                         isNewTyCon, isAlgTyCon, isFunTyCon, isPrimTyCon,
+                         isFunTyCon, isPrimTyCon,
                        )
 import Type            ( Type, typePrimRep, splitAlgTyConApp, 
                          splitTyConApp_maybe, repType )
-import PprType         ( {- instance Outputable Type -} )
-import Unique           ( Unique, Uniquable(..), mkPseudoUnique1 )
+import Unique           ( Unique, Uniquable(..), newTagUnique )
 import Maybes          ( maybeToBool )
 import Util
 import Outputable
@@ -145,9 +142,10 @@ 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).
+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}
 cgCase (StgPrimApp op args res_ty)
@@ -157,7 +155,7 @@ cgCase (StgPrimApp op args res_ty)
 
     let tag_amode = case op of 
                        TagToEnumOp -> only arg_amodes
-                       _ -> CTemp (mkPseudoUnique1{-see above-} 1) IntRep
+                       _ -> CTemp (newTagUnique (getUnique bndr) 'C') IntRep
 
        closure = CVal (CIndex (CLbl (mkClosureTblLabel tycon) PtrRep) tag_amode PtrRep) PtrRep
     in
@@ -404,7 +402,7 @@ getPrimAppResultAmodes uniq (StgAlgAlts ty alts some_default)
                [ 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))
+  | otherwise = pprPanic "getPrimAppResultAmodes: case of primop has strange type:" (ppr ty)
 
   where (tycon, _, _) = splitAlgTyConApp ty
 
@@ -876,7 +874,7 @@ restoreCurrentCostCentre (Just slot)
    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
+    -- assigning into CurCostCentre, in case RESTORE_CCCS
     -- has some sanity-checking in it.
 \end{code}
 
@@ -901,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...
@@ -950,7 +946,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
-          Nothing -> CLbl mkErrorStdEntryLabel CodePtrRep 
+          Nothing -> mkIntCLit 0 -- CLbl mkErrorStdEntryLabel CodePtrRep 
           Just absC@(CCodeBlock lbl _) -> CLbl lbl CodePtrRep
 
     mk_vector_entry :: ConTag -> (CAddrMode, AbstractC)