diff --git a/ghc/compiler/absCSyn/AbsCSyn.lhs b/ghc/compiler/absCSyn/AbsCSyn.lhs
index dfaf400f06882af11f06f91d294c82b2519e2bf9..a8445bb4ac5e46fc8c3a595515cb588ba370a2fd 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 e90719c3c886f7fe508b2332ed47a1b0d3bf4da0..072be07db7e121cbc8f7a301a9a4ee32c3f3e0d4 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 67b22b551fb0293085c676c3b75acc274a709162..721a1215ed69eb38ae4aa476afc8cc12092995c2 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 [
@@ -627,6 +636,12 @@ pp_srt_info srt =
int len, comma ]
\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
diff --git a/ghc/compiler/basicTypes/Unique.lhs b/ghc/compiler/basicTypes/Unique.lhs
index 396c20bdc2a87e5655f0ac454d8b57ad5467cc5e..81e137ded156fd7dc1d5802d998bd4e034bee051 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 12c50649ffb4d6366daf854729d0522b310393f9..99d286ea7c22a46e76fa704661351f6fbd905524 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 de18e05b966176b97e9059d12cd64089fa42d7c3..33022296a4377c646d5ed28819bd7a67ce829d89 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 f183292f10ca077a47213301d3e37554700a54a1..16f6d9d4731e830d5eb2e3b6285b22daa276e75f 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 1af5fbf652ea65b151bed39d96f7a6654a0555d3..1dfaf8242ac2763086fe97be3deb6bd45472fb96 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 62d67a836436b7b5083c283c71e0f1eda9f3cd06..a763a7c4a7473f5833e22a5ad5760e4feb9fb1c1 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 f97ea1b6aa36465a5a24dfba9e42149b7102f3a5..c5de5edc4dcd2acc13265c0342623e3b84567aa0 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 884817e258dbf1343df61ec8a37667264a276ae2..77f3c4276b9ede60bae43080c0935a7ab288d095 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