[project @ 1999-04-26 16:06:27 by simonm]

- New Wired-in Id: getTag# :: a -> Int#
	for a data type, returns the tag of the constructor.
	for a function, returns a spurious number probably.
	dataToTag# is the name of the underlying primitive which
	pulls out the tag (its argument is assumed to be
	evaluated).

- Generate constructor tables for enumerated types, so we
  can do tagToEnum#.

- Remove hacks in CoreToStg for dataToTag#.

diff --git a/ghc/compiler/absCSyn/AbsCSyn.lhs b/ghc/compiler/absCSyn/AbsCSyn.lhs
index dfaf400..a8445bb 100644 (file)
--- a/ghc/compiler/absCSyn/AbsCSyn.lhs
+++ b/ghc/compiler/absCSyn/AbsCSyn.lhs
@@ -1,7 +1,7 @@
 %
 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
 %
-% $Id: AbsCSyn.lhs,v 1.21 1999/03/11 11:32:22 simonm Exp $
+% $Id: AbsCSyn.lhs,v 1.22 1999/04/26 16:06:27 simonm Exp $
 %
 \section[AbstractC]{Abstract C: the last stop before machine code}
 
@@ -52,6 +52,7 @@ import PrimRep                ( PrimRep(..) )
 import PrimOp           ( PrimOp )
 import Unique           ( Unique )
 import StgSyn          ( SRT(..) )
+import TyCon           ( TyCon )
 import BitSet                          -- for liveness masks
 
 \end{code}
@@ -196,6 +197,9 @@ stored in a mixed type location.)
        (CLabel,SRT)            -- SRT info
        Liveness                -- stack liveness at the return point
 
+  | CClosureTbl                -- table of constructors for enumerated types
+       TyCon                   -- which TyCon this table is for
+
   | CCostCentreDecl            -- A cost centre *declaration*
        Bool                    -- True  <=> local => full declaration
                                -- False <=> extern; just say so

diff --git a/ghc/compiler/absCSyn/AbsCUtils.lhs b/ghc/compiler/absCSyn/AbsCUtils.lhs
index e90719c..072be07 100644 (file)
--- a/ghc/compiler/absCSyn/AbsCUtils.lhs
+++ b/ghc/compiler/absCSyn/AbsCUtils.lhs
@@ -362,6 +362,7 @@ flatAbsC stmt@(COpStmt results op args vol_regs)= returnFlt (stmt, AbsCNop)
 -- Some statements only make sense at the top level, so we always float
 -- them.  This probably isn't necessary.
 flatAbsC stmt@(CStaticClosure _ _ _ _)         = returnFlt (AbsCNop, stmt)
+flatAbsC stmt@(CClosureTbl _)                  = returnFlt (AbsCNop, stmt)
 flatAbsC stmt@(CSRT _ _)                       = returnFlt (AbsCNop, stmt)
 flatAbsC stmt@(CBitmap _ _)                    = returnFlt (AbsCNop, stmt)
 flatAbsC stmt@(CCostCentreDecl _ _)            = returnFlt (AbsCNop, stmt)

diff --git a/ghc/compiler/absCSyn/PprAbsC.lhs b/ghc/compiler/absCSyn/PprAbsC.lhs
index 67b22b5..721a121 100644 (file)
--- a/ghc/compiler/absCSyn/PprAbsC.lhs
+++ b/ghc/compiler/absCSyn/PprAbsC.lhs
@@ -29,7 +29,8 @@ import Constants      ( mIN_UPD_SIZE )
 import CallConv                ( CallConv, callConvAttribute, cCallConv )
 import CLabel          ( externallyVisibleCLabel, mkErrorStdEntryLabel,
                          isReadOnly, needsCDecl, pprCLabel,
-                         mkReturnInfoLabel, mkReturnPtLabel,
+                         mkReturnInfoLabel, mkReturnPtLabel, mkClosureTblLabel,
+                         mkStaticClosureLabel,
                          CLabel, CLabelType(..), labelType, labelDynamic
                        )
 
@@ -40,6 +41,9 @@ import Costs          ( costs, addrModeCosts, CostRes(..), Side(..) )
 import CStrings                ( stringToC )
 import FiniteMap       ( addToFM, emptyFM, lookupFM, FiniteMap )
 import Const           ( Literal(..) )
+import TyCon           ( tyConDataCons )
+import Name            ( NamedThing(..) )
+import DataCon         ( DataCon{-instance NamedThing-} )
 import Maybes          ( maybeToBool, catMaybes )
 import PrimOp          ( primOpNeedsWrapper, pprPrimOp, PrimOp(..) )
 import PrimRep         ( isFloatingRep, PrimRep(..), getPrimRepSize, showPrimRep )
@@ -251,10 +255,6 @@ pprAbsC stmt@(CSRT lbl closures) c
       $$ nest 2 (hcat (punctuate comma (map pp_closure_lbl closures)))
          <> ptext SLIT("};")
   }
-  where 
-    pp_closure_lbl lbl
-      | labelDynamic lbl = text "DLL_SRT_ENTRY" <> parens (pprCLabel lbl)
-      | otherwise       = char '&' <> pprCLabel lbl
 
 pprAbsC stmt@(CBitmap lbl mask) c
   = vcat [
@@ -461,6 +461,15 @@ pprAbsC stmt@(CClosureInfoAndCode cl_info slow maybe_fast cl_descr) _
     pp_descr = hcat [char '"', text (stringToC cl_descr), char '"']
     pp_type  = hcat [char '"', text (stringToC (closureTypeDescr cl_info)), char '"']
 
+pprAbsC stmt@(CClosureTbl tycon) _
+  = vcat (
+       ptext SLIT("CLOSURE_TBL") <> 
+          lparen <> pprCLabel (mkClosureTblLabel tycon) <> rparen :
+       punctuate comma (
+          map (pp_closure_lbl . mkStaticClosureLabel . getName) (tyConDataCons tycon)
+       )
+   ) $$ ptext SLIT("};")
+
 pprAbsC stmt@(CRetDirect uniq code srt liveness) _
   = vcat [
       hcat [
@@ -628,6 +637,12 @@ pp_srt_info srt =
 \end{code}
 
 \begin{code}
+pp_closure_lbl lbl
+      | labelDynamic lbl = text "DLL_SRT_ENTRY" <> parens (pprCLabel lbl)
+      | otherwise       = char '&' <> pprCLabel lbl
+\end{code}
+
+\begin{code}
 if_profiling pretty
   = if  opt_SccProfilingOn
     then pretty

diff --git a/ghc/compiler/basicTypes/Unique.lhs b/ghc/compiler/basicTypes/Unique.lhs
index 396c20b..81e137d 100644 (file)
--- a/ghc/compiler/basicTypes/Unique.lhs
+++ b/ghc/compiler/basicTypes/Unique.lhs
@@ -95,6 +95,7 @@ module Unique (
        funTyConKey,
        functorClassKey,
        geClassOpKey,
+       getTagIdKey,
        intDataConKey,
        intPrimTyConKey,
        intTyConKey,
@@ -606,6 +607,7 @@ zipIdKey                  = mkPreludeMiscIdUnique 35
 bindIOIdKey                  = mkPreludeMiscIdUnique 36
 deRefStablePtrIdKey          = mkPreludeMiscIdUnique 37
 makeStablePtrIdKey           = mkPreludeMiscIdUnique 38
+getTagIdKey                  = mkPreludeMiscIdUnique 39
 \end{code}
 
 Certain class operations from Prelude classes.  They get their own

diff --git a/ghc/compiler/codeGen/CgConTbls.lhs b/ghc/compiler/codeGen/CgConTbls.lhs
index 12c5064..99d286e 100644 (file)
--- a/ghc/compiler/codeGen/CgConTbls.lhs
+++ b/ghc/compiler/codeGen/CgConTbls.lhs
@@ -12,7 +12,7 @@ import AbsCSyn
 import CgMonad
 
 import StgSyn          ( SRT(..) )
-import AbsCUtils       ( mkAbstractCs )
+import AbsCUtils       ( mkAbstractCs, mkAbsCStmts )
 import CgTailCall      ( performReturn, mkStaticAlgReturnCode )
 import CLabel          ( mkConEntryLabel, mkStaticClosureLabel )
 import ClosureInfo     ( layOutStaticClosure, layOutDynCon,
@@ -24,7 +24,7 @@ import DataCon                ( DataCon, dataConName, dataConRawArgTys )
 import Const           ( Con(..) )
 import Name            ( getOccString )
 import PrimRep         ( getPrimRepSize, PrimRep(..) )
-import TyCon           ( tyConDataCons, TyCon )
+import TyCon           ( tyConDataCons, isEnumerationTyCon, TyCon )
 import Type            ( typePrimRep, Type )
 import BasicTypes      ( TopLevelFlag(..) )
 import Outputable      
@@ -96,7 +96,13 @@ genStaticConBits comp_info gen_tycons tycon_specs
   where
     gen_for_tycon :: TyCon -> AbstractC
     gen_for_tycon tycon
-      = mkAbstractCs (map (genConInfo comp_info tycon) (tyConDataCons tycon))
+      = mkAbstractCs (map (genConInfo comp_info tycon) (tyConDataCons tycon)) 
+       `mkAbsCStmts` (
+         -- after the con decls, so we don't need to declare the constructor labels
+         if (isEnumerationTyCon tycon)
+           then CClosureTbl tycon
+           else AbsCNop
+       )
 \end{code}
 
 %************************************************************************

diff --git a/ghc/compiler/prelude/PrelInfo.lhs b/ghc/compiler/prelude/PrelInfo.lhs
index de18e05..3302229 100644 (file)
--- a/ghc/compiler/prelude/PrelInfo.lhs
+++ b/ghc/compiler/prelude/PrelInfo.lhs
@@ -51,7 +51,7 @@ module PrelInfo (
        ltH_Float_RDR, eqH_Double_RDR, ltH_Double_RDR, eqH_Int_RDR, 
        ltH_Int_RDR, geH_RDR, leH_RDR, minusH_RDR, false_RDR, true_RDR,
        and_RDR, not_RDR, append_RDR, map_RDR, compose_RDR, mkInt_RDR,
-       error_RDR, assertErr_RDR, dataToTagH_RDR,
+       error_RDR, assertErr_RDR, getTag_RDR,
        showString_RDR, showParen_RDR, readParen_RDR, lex_RDR,
        showSpace_RDR, showList___RDR, readList___RDR, negate_RDR,
 
@@ -221,9 +221,10 @@ wired_in_ids
     , rEC_CON_ERROR_ID
     , rEC_UPD_ERROR_ID
 
-       -- These two can't be defined in Haskell
+       -- These three can't be defined in Haskell
     , realWorldPrimId
     , unsafeCoerceId
+    , getTagId
     ]
 
 \end{code}
@@ -566,7 +567,8 @@ ltH_Int_RDR = prelude_primop IntLtOp
 geH_RDR                = prelude_primop IntGeOp
 leH_RDR                = prelude_primop IntLeOp
 minusH_RDR     = prelude_primop IntSubOp
-dataToTagH_RDR  = prelude_primop DataToTagOp
+
+getTag_RDR     = varQual pREL_GHC SLIT("getTag#")
 \end{code}
 
 \begin{code}

diff --git a/ghc/compiler/prelude/PrelVals.lhs b/ghc/compiler/prelude/PrelVals.lhs
index f183292..16f6d9d 100644 (file)
--- a/ghc/compiler/prelude/PrelVals.lhs
+++ b/ghc/compiler/prelude/PrelVals.lhs
@@ -20,6 +20,8 @@ import TysWiredIn
 -- others:
 import CoreSyn         -- quite a bit
 import IdInfo          -- quite a bit
+import PrimOp          ( PrimOp(..) )
+import Const           ( Con(..) )
 import Module          ( Module )
 import Name            ( mkWiredInIdName, mkSrcVarOcc )
 import Type            
@@ -61,6 +63,21 @@ unsafeCoerceId
               Note (Coerce betaTy alphaTy) (Var x)
 \end{code}
 
+@getTag#@ is another function which can't be defined in Haskell.  It needs to
+evaluate its argument and call the dataToTag# primitive.
+
+\begin{code}
+getTagId
+  = pcMiscPrelId getTagIdKey pREL_GHC SLIT("getTag#") ty 
+       (mk_inline_unfolding template)
+  where
+    ty = mkForAllTys [alphaTyVar] (mkFunTy alphaTy intPrimTy)
+    [x,y] = mkTemplateLocals [alphaTy,alphaTy]
+    template = mkLams [alphaTyVar,x] $
+              Case (Var x) y [ (DEFAULT, [], 
+                  Con (PrimOp DataToTagOp) [Type alphaTy, Var y]) ]
+\end{code}
+
 
 @realWorld#@ used to be a magic literal, \tr{void#}.  If things get
 nasty as-is, change it back to a literal (@Literal@).

diff --git a/ghc/compiler/simplCore/ConFold.lhs b/ghc/compiler/simplCore/ConFold.lhs
index 1af5fbf..1dfaf82 100644 (file)
--- a/ghc/compiler/simplCore/ConFold.lhs
+++ b/ghc/compiler/simplCore/ConFold.lhs
@@ -20,6 +20,8 @@ import SimplMonad
 import TysWiredIn      ( trueDataCon, falseDataCon )
 import TyCon           ( tyConDataCons, isEnumerationTyCon )
 import DataCon         ( dataConTag, fIRST_TAG )
+import Const           ( conOkForAlt )
+import CoreUnfold      ( Unfolding(..) )
 import Type            ( splitTyConApp_maybe )
 
 import Char            ( ord, chr )
@@ -104,14 +106,24 @@ tryPrimOp TagToEnumOp [Type ty, Con (Literal (MachInt i _)) _]
          constrs = tyConDataCons tycon
          (dc:_) = [ dc | dc <- constrs, tag == dataConTag dc ]
          (Just (tycon,_)) = splitTyConApp_maybe ty
+\end{code}
+
+For dataToTag#, we can reduce if either 
+       
+       (a) the argument is a constructor
+       (b) the argument is a variable whose unfolding is a known constructor
 
+\begin{code}
 tryPrimOp DataToTagOp [Type ty, Con (DataCon dc) _]
   = Just (Con (Literal (mkMachInt (toInteger (dataConTag dc - fIRST_TAG)))) [])
 tryPrimOp DataToTagOp [Type ty, Var x]
-  | unfolding_is_constr
+  | has_unfolding && unfolding_is_constr
   = Just (Con (Literal (mkMachInt (toInteger (dataConTag dc - fIRST_TAG)))) [])
   where
-    unfolding = getIdUnfolding var
+    has_unfolding = case unfolding of
+                       CoreUnfolding _ _ _ -> True
+                       other               -> False
+    unfolding = getIdUnfolding x
     CoreUnfolding form guidance unf_template = unfolding
     unfolding_is_constr = case unf_template of
                                  Con con@(DataCon _) _ -> conOkForAlt con

diff --git a/ghc/compiler/simplCore/SimplCore.lhs b/ghc/compiler/simplCore/SimplCore.lhs
index 62d67a8..a763a7c 100644 (file)
--- a/ghc/compiler/simplCore/SimplCore.lhs
+++ b/ghc/compiler/simplCore/SimplCore.lhs
@@ -35,8 +35,9 @@ import Id             ( Id, mkSysLocal, mkUserId, isBottomingId,
                        )
 import IdInfo          ( InlinePragInfo(..), specInfo, setSpecInfo,
                          inlinePragInfo, setInlinePragInfo,
-                         setUnfoldingInfo
+                         setUnfoldingInfo, setDemandInfo
                        )
+import Demand          ( wwLazy )
 import VarEnv
 import VarSet
 import Module          ( Module )
@@ -370,7 +371,7 @@ tidyIdInfo env info
                ICanSafelyBeINLINEd _ _ -> NoInlinePragInfo `setInlinePragInfo` info1
                other                   -> info1
 
-    info3 = noUnfolding `setUnfoldingInfo` info2
+    info3 = noUnfolding `setUnfoldingInfo` (wwLazy `setDemandInfo`  info2)
 
     tidy_item (tyvars, tys, rhs)
        = (tyvars', tidyTypes env' tys, tidyExpr env' rhs)

diff --git a/ghc/compiler/stgSyn/CoreToStg.lhs b/ghc/compiler/stgSyn/CoreToStg.lhs
index f97ea1b..c5de5ed 100644 (file)
--- a/ghc/compiler/stgSyn/CoreToStg.lhs
+++ b/ghc/compiler/stgSyn/CoreToStg.lhs
@@ -437,16 +437,6 @@ coreExprToStgFloat env expr@(Con (PrimOp (CCallOp (Right _) a b c)) args)
     let con' = PrimOp (CCallOp (Right u) a b c) in
     returnUs (binds, StgCon con' stg_atoms (coreExprType expr))
 
--- for dataToTag#, we need to make sure the argument is evaluated first.
-coreExprToStgFloat env expr@(Con op@(PrimOp DataToTagOp) [Type ty, a])
-  = newStgVar ty               `thenUs` \ v ->
-    coreArgToStg env a         `thenUs` \ (binds, arg) ->
-    let e = case arg of
-               StgVarArg v -> StgApp v []
-               StgConArg c -> StgCon c [] (coreExprType a)
-    in
-    returnUs (binds ++ [CaseBind v e], StgCon op [StgVarArg v] (coreExprType expr))
-
 coreExprToStgFloat env expr@(Con con args)
   = coreArgsToStg env args     `thenUs` \ (binds, stg_atoms) ->
     returnUs (binds, StgCon con stg_atoms (coreExprType expr))

diff --git a/ghc/compiler/typecheck/TcGenDeriv.lhs b/ghc/compiler/typecheck/TcGenDeriv.lhs
index 884817e..77f3c42 100644 (file)
--- a/ghc/compiler/typecheck/TcGenDeriv.lhs
+++ b/ghc/compiler/typecheck/TcGenDeriv.lhs
@@ -1066,7 +1066,7 @@ gen_tag_n_con_monobind
 gen_tag_n_con_monobind (rdr_name, tycon, GenCon2Tag)
   | lots_of_constructors
   = mk_FunMonoBind (getSrcLoc tycon) rdr_name 
-       [([VarPatIn a_RDR], HsApp dataToTag_Expr a_Expr)]
+       [([VarPatIn a_RDR], HsApp getTag_Expr a_Expr)]
 
   | otherwise
   = mk_FunMonoBind (getSrcLoc tycon) rdr_name (map mk_stuff (tyConDataCons tycon))
@@ -1361,7 +1361,7 @@ gtTag_Expr        = HsVar gtTag_RDR
 false_Expr     = HsVar false_RDR
 true_Expr      = HsVar true_RDR
 
-dataToTag_Expr  = HsVar dataToTagH_RDR
+getTag_Expr    = HsVar getTag_RDR
 con2tag_Expr tycon = HsVar (con2tag_RDR tycon)
 
 a_Pat          = VarPatIn a_RDR