[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#.

11 files changed, 78 insertions, 28 deletions

diff --git a/ghc/compiler/absCSyn/AbsCSyn.lhs b/ghc/compiler/absCSyn/AbsCSyn.lhs
index dfaf400f06..a8445bb4ac 100644
--- 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 e90719c3c8..072be07db7 100644
--- 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 67b22b551f..721a1215ed 100644
--- 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 396c20bdc2..81e137ded1 100644
--- 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 12c50649ff..99d286ea7c 100644
--- 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 de18e05b96..33022296a4 100644
--- 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 f183292f10..16f6d9d473 100644
--- 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 1af5fbf652..1dfaf8242a 100644
--- 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 62d67a8364..a763a7c4a7 100644
--- 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 f97ea1b6aa..c5de5edc4d 100644
--- 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 884817e258..77f3c4276b 100644
--- 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