Commit aae36781 authored by simonm's avatar simonm
Browse files

[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#.
parent 0755a7d9
%
% (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
......
......@@ -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)
......
......@@ -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
......
......@@ -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
......
......@@ -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}
%************************************************************************
......
......@@ -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}
......
......@@ -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@).
......
......@@ -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
......
......@@ -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)
......
......@@ -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))
......
......@@ -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
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment