[project @ 1997-05-26 05:04:53 by sof]

Updated imports; new functions: isAlgDataCon, isNewCon, addDeforestInfo, replacePragmaInfo;

diff --git a/ghc/compiler/basicTypes/Id.lhs b/ghc/compiler/basicTypes/Id.lhs
index 786d69a..0254728 100644 (file)
--- 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 ->