From 07b2ea4725a4fef7558fe9e07e2fb16d9e66784f Mon Sep 17 00:00:00 2001 From: sof Date: Mon, 26 May 1997 05:04:53 +0000 Subject: [PATCH] [project @ 1997-05-26 05:04:53 by sof] Updated imports; new functions: isAlgDataCon, isNewCon, addDeforestInfo, replacePragmaInfo; --- ghc/compiler/basicTypes/Id.lhs | 104 +++++++++++++++++++++------------------- 1 file changed, 55 insertions(+), 49 deletions(-) diff --git a/ghc/compiler/basicTypes/Id.lhs b/ghc/compiler/basicTypes/Id.lhs index 786d69a..0254728 100644 --- a/ghc/compiler/basicTypes/Id.lhs +++ b/ghc/compiler/basicTypes/Id.lhs @@ -58,12 +58,12 @@ module Id ( cmpId_withSpecDataCon, externallyVisibleId, idHasNoFreeTyVars, - idWantsToBeINLINEd, getInlinePragma, + idWantsToBeINLINEd, getInlinePragma, idMustBeINLINEd, idMustNotBeINLINEd, isBottomingId, isConstMethodId, isConstMethodId_maybe, - isDataCon, + isDataCon, isAlgCon, isNewCon, isDefaultMethodId, isDefaultMethodId_maybe, isDictFunId, @@ -102,6 +102,7 @@ module Id ( addIdDemandInfo, addIdStrictness, addIdUpdateInfo, + addIdDeforestInfo, getIdArity, getIdDemandInfo, getIdInfo, @@ -109,7 +110,7 @@ module Id ( getIdUnfolding, getIdUpdateInfo, getPragmaInfo, - replaceIdInfo, + replaceIdInfo, replacePragmaInfo, addInlinePragma, nukeNoInlinePragma, addNoInlinePragma, -- IdEnvs AND IdSets @@ -153,14 +154,15 @@ import Bag import Class ( classOpString, SYN_IE(Class), GenClass, SYN_IE(ClassOp), GenClassOp ) import IdInfo import Maybes ( maybeToBool ) -import Name {- ( nameUnique, mkLocalName, mkSysLocalName, isLocalName, +import Name ( nameUnique, mkLocalName, mkSysLocalName, isLocalName, mkCompoundName, mkInstDeclName, isLocallyDefinedName, occNameString, modAndOcc, isLocallyDefined, changeUnique, isWiredInName, nameString, getOccString, setNameVisibility, isExported, ExportFlag(..), DefnInfo, Provenance, - OccName(..), Name - ) -} + OccName(..), Name, SYN_IE(Module), + NamedThing(..) + ) import PrelMods ( pREL_TUP, pREL_BASE ) import Lex ( mkTupNameStr ) import FieldLabel ( fieldLabelName, FieldLabel(..){-instances-} ) @@ -173,7 +175,6 @@ import PprType ( getTypeString, specMaybeTysSuffix, nmbrType, nmbrTyVar, GenType, GenTyVar ) -import PprStyle import Pretty import MatchEnv ( MatchEnv ) import SrcLoc --( mkBuiltinSrcLoc ) @@ -192,7 +193,7 @@ import Unique ( getBuiltinUniques, pprUnique, showUnique, incrUnique, Unique{-instance Ord3-} ) -import Outputable ( ifPprDebug, Outputable(..) ) +import Outputable ( ifPprDebug, Outputable(..), PprStyle(..) ) import Util {- ( mapAccumL, nOfThem, zipEqual, assoc, panic, panic#, pprPanic, assertPanic ) -} @@ -244,7 +245,9 @@ data IdDetails ---------------- Data constructors - | DataConId ConTag + | AlgConId -- Used for both data and newtype constructors. + -- You can tell the difference by looking at the TyCon + ConTag [StrictnessMark] -- Strict args; length = arity [FieldLabel] -- Field labels for this constructor; --length = 0 (not a record) or arity @@ -399,7 +402,7 @@ class method. \begin{description} %---------------------------------------------------------------------- -\item[@DataConId@:] For the data constructors declared by a @data@ +\item[@AlgConId@:] For the data constructors declared by a @data@ declaration. Their type is kept in {\em two} forms---as a regular @Type@ (in the usual place), and also in its constituent pieces (in the ``details''). We are frequently interested in those pieces. @@ -486,27 +489,24 @@ properties, but they may not. %************************************************************************ \begin{code} -isDataCon (Id _ _ _ (DataConId _ __ _ _ _ _ _ _) _ _) = True -isDataCon (Id _ _ _ (TupleConId _) _ _) = True -isDataCon (Id _ _ _ (SpecId unspec _ _) _ _) = isDataCon unspec -isDataCon other = False +-- isDataCon returns False for @newtype@ constructors +isDataCon (Id _ _ _ (AlgConId _ _ _ _ _ _ _ _ tc) _ _) = isDataTyCon tc +isDataCon (Id _ _ _ (TupleConId _) _ _) = True +isDataCon (Id _ _ _ (SpecId unspec _ _) _ _) = isDataCon unspec +isDataCon other = False + +isNewCon (Id _ _ _ (AlgConId _ _ _ _ _ _ _ _ tc) _ _) = isNewTyCon tc +isNewCon other = False + +-- isAlgCon returns True for @data@ or @newtype@ constructors +isAlgCon (Id _ _ _ (AlgConId _ _ _ _ _ _ _ _ _) _ _) = True +isAlgCon (Id _ _ _ (TupleConId _) _ _) = True +isAlgCon (Id _ _ _ (SpecId unspec _ _) _ _) = isAlgCon unspec +isAlgCon other = False isTupleCon (Id _ _ _ (TupleConId _) _ _) = True isTupleCon (Id _ _ _ (SpecId unspec _ _) _ _) = isTupleCon unspec isTupleCon other = False - -{-LATER: -isSpecId_maybe (Id _ _ _ (SpecId unspec ty_maybes _) _ _) - = ASSERT(not (maybeToBool (isSpecId_maybe unspec))) - Just (unspec, ty_maybes) -isSpecId_maybe other_id - = Nothing - -isSpecPragmaId_maybe (Id _ _ _ (SpecPragmaId specid _) _ _) - = Just specid -isSpecPragmaId_maybe other_id - = Nothing --} \end{code} @toplevelishId@ tells whether an @Id@ {\em may} be defined in a nested @@ -522,7 +522,7 @@ idHasNoFreeTyVars :: Id -> Bool toplevelishId (Id _ _ _ details _ _) = chk details where - chk (DataConId _ __ _ _ _ _ _ _) = True + chk (AlgConId _ __ _ _ _ _ _ _) = True chk (TupleConId _) = True chk (RecordSelId _) = True chk ImportedId = True @@ -543,7 +543,7 @@ toplevelishId (Id _ _ _ details _ _) idHasNoFreeTyVars (Id _ _ _ details _ info) = chk details where - chk (DataConId _ _ _ _ _ _ _ _ _) = True + chk (AlgConId _ _ _ _ _ _ _ _ _) = True chk (TupleConId _) = True chk (RecordSelId _) = True chk ImportedId = True @@ -581,7 +581,7 @@ omitIfaceSigForId (Id _ name _ details _ _) -- remember that all type and class decls appear in the interface file. -- The dfun id must *not* be omitted, because it carries version info for -- the instance decl - (DataConId _ _ _ _ _ _ _ _ _) -> True + (AlgConId _ _ _ _ _ _ _ _ _) -> True (TupleConId _) -> True (RecordSelId _) -> True (SuperDictSelId _ _) -> True @@ -963,15 +963,10 @@ getIdInfo (Id _ _ _ _ _ info) = info getPragmaInfo (Id _ _ _ _ info _) = info replaceIdInfo :: Id -> IdInfo -> Id - replaceIdInfo (Id u n ty details pinfo _) info = Id u n ty details pinfo info -{-LATER: -selectIdInfoForSpecId :: Id -> IdInfo -selectIdInfoForSpecId unspec - = ASSERT(not (maybeToBool (isSpecId_maybe unspec))) - noIdInfo `addUnfoldInfo` getIdUnfolding unspec --} +replacePragmaInfo :: Id -> PragmaInfo -> Id +replacePragmaInfo (Id u sn ty details _ info) prag = Id u sn ty details prag info \end{code} %************************************************************************ @@ -987,8 +982,7 @@ besides the code-generator need arity info!) \begin{code} getIdArity :: Id -> ArityInfo getIdArity id@(Id _ _ _ _ _ id_info) - = --ASSERT( not (isDataCon id)) - arityInfo id_info + = arityInfo id_info addIdArity :: Id -> ArityInfo -> Id addIdArity (Id u n ty details pinfo info) arity @@ -997,6 +991,18 @@ addIdArity (Id u n ty details pinfo info) arity %************************************************************************ %* * +\subsection[Id-arities]{Deforestation related functions} +%* * +%************************************************************************ + +\begin{code} +addIdDeforestInfo :: Id -> DeforestInfo -> Id +addIdDeforestInfo (Id u n ty details pinfo info) def_info + = Id u n ty details pinfo (info `addDeforestInfo` def_info) +\end{code} + +%************************************************************************ +%* * \subsection[constructor-funs]{@DataCon@-related functions (incl.~tuples)} %* * %************************************************************************ @@ -1020,7 +1026,7 @@ mkDataCon n stricts fields tvs ctxt con_tvs con_ctxt args_tys tycon = Id (nameUnique n) n data_con_ty - (DataConId data_con_tag stricts fields tvs ctxt con_tvs con_ctxt args_tys tycon) + (AlgConId data_con_tag stricts fields tvs ctxt con_tvs con_ctxt args_tys tycon) IWantToBeINLINEd -- Always inline constructors if possible noIdInfo @@ -1062,18 +1068,18 @@ isNullaryDataCon con = dataConNumFields con == 0 -- function of convenience \begin{code} dataConTag :: DataCon -> ConTag -- will panic if not a DataCon -dataConTag (Id _ _ _ (DataConId tag _ _ _ _ _ _ _ _) _ _) = tag +dataConTag (Id _ _ _ (AlgConId tag _ _ _ _ _ _ _ _) _ _) = tag dataConTag (Id _ _ _ (TupleConId _) _ _) = fIRST_TAG dataConTag (Id _ _ _ (SpecId unspec _ _) _ _) = dataConTag unspec dataConTyCon :: DataCon -> TyCon -- will panic if not a DataCon -dataConTyCon (Id _ _ _ (DataConId _ _ _ _ _ _ _ _ tycon) _ _) = tycon +dataConTyCon (Id _ _ _ (AlgConId _ _ _ _ _ _ _ _ tycon) _ _) = tycon dataConTyCon (Id _ _ _ (TupleConId a) _ _) = tupleTyCon a dataConSig :: DataCon -> ([TyVar], ThetaType, [TyVar], ThetaType, [TauType], TyCon) -- will panic if not a DataCon -dataConSig (Id _ _ _ (DataConId _ _ _ tyvars theta con_tyvars con_theta arg_tys tycon) _ _) +dataConSig (Id _ _ _ (AlgConId _ _ _ tyvars theta con_tyvars con_theta arg_tys tycon) _ _) = (tyvars, theta, con_tyvars, con_theta, arg_tys, tycon) dataConSig (Id _ _ _ (TupleConId arity) _ _) @@ -1102,11 +1108,11 @@ dataConRepType con (tyvars, theta, tau) = splitSigmaTy (idType con) dataConFieldLabels :: DataCon -> [FieldLabel] -dataConFieldLabels (Id _ _ _ (DataConId _ _ fields _ _ _ _ _ _) _ _) = fields +dataConFieldLabels (Id _ _ _ (AlgConId _ _ fields _ _ _ _ _ _) _ _) = fields dataConFieldLabels (Id _ _ _ (TupleConId _) _ _) = [] dataConStrictMarks :: DataCon -> [StrictnessMark] -dataConStrictMarks (Id _ _ _ (DataConId _ stricts _ _ _ _ _ _ _) _ _) = stricts +dataConStrictMarks (Id _ _ _ (AlgConId _ stricts _ _ _ _ _ _ _) _ _) = stricts dataConStrictMarks (Id _ _ _ (TupleConId arity) _ _) = nOfThem arity NotMarkedStrict @@ -1510,7 +1516,7 @@ nmbrId id@(Id u n ty det prag info) nenv@(NmbrEnv ui ut uu idenv tvenv uvenv) nmbrDataCon id@(Id _ _ _ (TupleConId _) _ _) nenv = (nenv, id) -- nothing to do for tuples -nmbrDataCon id@(Id u n ty (DataConId tag marks fields tvs theta con_tvs con_theta arg_tys tc) prag info) +nmbrDataCon id@(Id u n ty (AlgConId tag marks fields tvs theta con_tvs con_theta arg_tys tc) prag info) nenv@(NmbrEnv ui ut uu idenv tvenv uvenv) = case (lookupUFM_Directly idenv u) of Just xx -> trace "nmbrDataCon: in env???\n" (nenv, xx) @@ -1519,7 +1525,7 @@ nmbrDataCon id@(Id u n ty (DataConId tag marks fields tvs theta con_tvs con_thet (nenv2, new_fields) = (mapNmbr nmbrField fields) nenv (nenv3, new_arg_tys) = (mapNmbr nmbrType arg_tys) nenv2 - new_det = DataConId tag marks new_fields (bottom "tvs") (bottom "theta") (bottom "tvs") (bottom "theta") new_arg_tys tc + new_det = AlgConId tag marks new_fields (bottom "tvs") (bottom "theta") (bottom "tvs") (bottom "theta") new_arg_tys tc new_id = Id u n (bottom "ty") new_det prag info in (nenv3, new_id) @@ -1529,14 +1535,14 @@ nmbrDataCon id@(Id u n ty (DataConId tag marks fields tvs theta con_tvs con_thet ------------ nmbr_details :: IdDetails -> NmbrM IdDetails -nmbr_details (DataConId tag marks fields tvs theta con_tvs con_theta arg_tys tc) +nmbr_details (AlgConId tag marks fields tvs theta con_tvs con_theta arg_tys tc) = mapNmbr nmbrTyVar tvs `thenNmbr` \ new_tvs -> mapNmbr nmbrTyVar con_tvs `thenNmbr` \ new_con_tvs -> mapNmbr nmbrField fields `thenNmbr` \ new_fields -> mapNmbr nmbr_theta theta `thenNmbr` \ new_theta -> mapNmbr nmbr_theta con_theta `thenNmbr` \ new_con_theta -> mapNmbr nmbrType arg_tys `thenNmbr` \ new_arg_tys -> - returnNmbr (DataConId tag marks new_fields new_tvs new_theta new_con_tvs new_con_theta new_arg_tys tc) + returnNmbr (AlgConId tag marks new_fields new_tvs new_theta new_con_tvs new_con_theta new_arg_tys tc) where nmbr_theta (c,t) = --nmbrClass c `thenNmbr` \ new_c -> -- 1.7.10.4