From 42b63073fb5e71fcd539ab80289cf6cf2a5b9641 Mon Sep 17 00:00:00 2001 From: simonpj Date: Wed, 12 Feb 2003 15:01:44 +0000 Subject: [PATCH] [project @ 2003-02-12 15:01:31 by simonpj] ------------------------------------- Big upheaval to the way that constructors are named ------------------------------------- This commit enshrines the new story for constructor names. We could never really get External Core to work nicely before, but now it does. The story is laid out in detail in the Commentary ghc/docs/comm/the-beast/data-types.html so I will not repeat it here. [Manuel: the commentary isn't being updated, apparently.] However, the net effect is that in Core and in External Core, contructors look like constructors, and the way things are printed is all consistent. It is a fairly pervasive change (which is why it has been so long postponed), but I hope the question is now finally closed. All the libraries compile etc, and I've run many tests, but doubtless there will be some dark corners. --- ghc/compiler/absCSyn/PprAbsC.lhs | 3 +- ghc/compiler/basicTypes/DataCon.hi-boot-6 | 1 - ghc/compiler/basicTypes/DataCon.lhs | 124 ++++++++++++++++++++++------- ghc/compiler/basicTypes/Id.lhs | 16 ++-- ghc/compiler/basicTypes/IdInfo.lhs | 4 +- ghc/compiler/basicTypes/MkId.hi-boot-6 | 3 +- ghc/compiler/basicTypes/MkId.lhs | 91 +++++++++++---------- ghc/compiler/basicTypes/Name.lhs | 12 +-- ghc/compiler/basicTypes/OccName.lhs | 66 ++++++++++++--- ghc/compiler/basicTypes/RdrName.lhs | 8 +- ghc/compiler/codeGen/CgCon.lhs | 4 +- ghc/compiler/coreSyn/CorePrep.lhs | 17 ++-- ghc/compiler/coreSyn/CoreUnfold.lhs | 2 +- ghc/compiler/coreSyn/CoreUtils.lhs | 18 ++--- ghc/compiler/coreSyn/MkExternalCore.lhs | 15 ++-- ghc/compiler/coreSyn/PprCore.lhs | 4 +- ghc/compiler/deSugar/DsMeta.hs | 4 +- ghc/compiler/ghci/ByteCodeGen.lhs | 11 ++- ghc/compiler/ghci/InteractiveUI.hs | 14 ++-- ghc/compiler/hsSyn/Convert.lhs | 10 +-- ghc/compiler/hsSyn/HsCore.lhs | 4 +- ghc/compiler/javaGen/JavaGen.lhs | 4 +- ghc/compiler/main/HscTypes.lhs | 69 ++++++++++------ ghc/compiler/main/MkIface.lhs | 5 +- ghc/compiler/nativeGen/AbsCStixGen.lhs | 3 +- ghc/compiler/parser/Parser.y | 21 ++--- ghc/compiler/parser/ParserCore.y | 39 ++++++--- ghc/compiler/parser/RdrHsSyn.lhs | 4 +- ghc/compiler/prelude/PrelInfo.lhs | 4 +- ghc/compiler/prelude/PrelNames.lhs | 7 +- ghc/compiler/prelude/TysWiredIn.lhs | 39 ++++----- ghc/compiler/rename/RnHiFiles.lhs | 22 ++--- ghc/compiler/rename/RnIfaces.lhs | 8 +- ghc/compiler/rename/RnNames.lhs | 4 +- ghc/compiler/simplCore/OccurAnal.lhs | 4 +- ghc/compiler/simplCore/SimplUtils.lhs | 4 +- ghc/compiler/simplCore/Simplify.lhs | 6 +- ghc/compiler/specialise/SpecConstr.lhs | 4 +- ghc/compiler/stgSyn/CoreToStg.lhs | 15 ++-- ghc/compiler/stranal/DmdAnal.lhs | 4 +- ghc/compiler/stranal/SaAbsInt.lhs | 4 +- ghc/compiler/typecheck/TcClassDcl.lhs | 30 +++---- ghc/compiler/typecheck/TcEnv.lhs | 33 +++++--- ghc/compiler/typecheck/TcIfaceSig.lhs | 14 ++-- ghc/compiler/typecheck/TcMType.lhs | 2 +- ghc/compiler/typecheck/TcMonoType.lhs | 7 +- ghc/compiler/typecheck/TcRnDriver.lhs | 5 +- ghc/compiler/typecheck/TcTyClsDecls.lhs | 32 +++----- ghc/compiler/typecheck/TcTyDecls.lhs | 72 +++++++++++------ ghc/compiler/typecheck/TcType.lhs | 27 ++++++- ghc/compiler/types/PprType.lhs | 11 +-- ghc/compiler/types/TyCon.lhs | 29 +++++-- ghc/compiler/types/Type.lhs | 25 ------ 53 files changed, 591 insertions(+), 397 deletions(-) diff --git a/ghc/compiler/absCSyn/PprAbsC.lhs b/ghc/compiler/absCSyn/PprAbsC.lhs index 2134f03..7094fbb 100644 --- a/ghc/compiler/absCSyn/PprAbsC.lhs +++ b/ghc/compiler/absCSyn/PprAbsC.lhs @@ -43,7 +43,6 @@ import FiniteMap ( addToFM, emptyFM, lookupFM, FiniteMap ) import Literal ( Literal(..) ) import TyCon ( tyConDataCons ) import Name ( NamedThing(..) ) -import DataCon ( dataConWrapId ) import Maybes ( catMaybes ) import PrimOp ( primOpNeedsWrapper ) import MachOp ( MachOp(..) ) @@ -473,7 +472,7 @@ pprAbsC stmt@(CClosureTbl tycon) _ ptext SLIT("CLOSURE_TBL") <> lparen <> pprCLabel (mkClosureTblLabel tycon) <> rparen : punctuate comma ( - map (pp_closure_lbl . mkClosureLabel . getName . dataConWrapId) (tyConDataCons tycon) + map (pp_closure_lbl . mkClosureLabel . getName) (tyConDataCons tycon) ) ) $$ ptext SLIT("};") diff --git a/ghc/compiler/basicTypes/DataCon.hi-boot-6 b/ghc/compiler/basicTypes/DataCon.hi-boot-6 index cdeeb9c..fa29c6b 100644 --- a/ghc/compiler/basicTypes/DataCon.hi-boot-6 +++ b/ghc/compiler/basicTypes/DataCon.hi-boot-6 @@ -1,5 +1,4 @@ module DataCon where data DataCon -dataConRepType :: DataCon -> TypeRep.Type isExistentialDataCon :: DataCon -> GHC.Base.Bool diff --git a/ghc/compiler/basicTypes/DataCon.lhs b/ghc/compiler/basicTypes/DataCon.lhs index 175427a..d3068da 100644 --- a/ghc/compiler/basicTypes/DataCon.lhs +++ b/ghc/compiler/basicTypes/DataCon.lhs @@ -13,7 +13,9 @@ module DataCon ( dataConRepArgTys, dataConTheta, dataConFieldLabels, dataConStrictMarks, dataConSourceArity, dataConRepArity, - dataConNumInstArgs, dataConWorkId, dataConWrapId, dataConRepStrictness, + dataConNumInstArgs, + dataConWorkId, dataConWrapId, dataConWrapId_maybe, + dataConRepStrictness, isNullaryDataCon, isTupleCon, isUnboxedTupleCon, isExistentialDataCon, classDataCon, dataConExistentialTyVars, @@ -40,27 +42,79 @@ import BasicTypes ( Arity, StrictnessMark(..) ) import Outputable import Unique ( Unique, Uniquable(..) ) import CmdLineOpts ( opt_UnboxStrictFields ) -import Maybe +import Maybes ( orElse ) import ListSetOps ( assoc ) import Util ( zipEqual, zipWithEqual, equalLength, notNull ) \end{code} -Stuff about data constructors -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Every constructor, C, comes with a +Data constructor representation +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider the following Haskell data type declaration - *wrapper*, called C, whose type is exactly what it looks like - in the source program. It is an ordinary function, - and it gets a top-level binding like any other function + data T = T !Int ![Int] + +Using the strictness annotations, GHC will represent this as + + data T = T Int# [Int] + +That is, the Int has been unboxed. Furthermore, the Haskell source construction + + T e1 e2 + +is translated to + + case e1 of { I# x -> + case e2 of { r -> + T x r }} + +That is, the first argument is unboxed, and the second is evaluated. Finally, +pattern matching is translated too: + + case e of { T a b -> ... } + +becomes + + case e of { T a' b -> let a = I# a' in ... } + +To keep ourselves sane, we name the different versions of the data constructor +differently, as follows. + + +Note [Data Constructor Naming] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Each data constructor C has two, and possibly three, Names associated with it: - *worker*, called $wC, which is the actual data constructor. - Its type may be different to C, because: + OccName Name space Used for + --------------------------------------------------------------------------- + * The "source data con" C DataName The DataCon itself + * The "real data con" C VarName Its worker Id + * The "wrapper data con" $wC VarName Wrapper Id (optional) + +Each of these three has a distinct Unique. The "source data con" name +appears in the output of the renamer, and names the Haskell-source +data constructor. The type checker translates it into either the wrapper Id +(if it exists) or worker Id (otherwise). + +The data con has one or two Ids associated with it: + + The "worker Id", is the actual data constructor. + Its type may be different to the Haskell source constructor + because: - useless dict args are dropped - strict args may be flattened - It does not have a binding. + The worker is very like a primop, in that it has no binding. + + Newtypes currently do get a worker-Id, but it is never used. + + + The "wrapper Id", $wC, whose type is exactly what it looks like + in the source program. It is an ordinary function, + and it gets a top-level binding like any other function. + + The wrapper Id isn't generated for a data type if the worker + and wrapper are identical. It's always generated for a newtype. - The worker is very like a primop, in that it has no binding, A note about the stupid context @@ -109,7 +163,8 @@ in an expression or in a pattern. data DataCon = MkData { -- Used for data constructors only; -- there *is* no constructor for a newtype - dcName :: Name, + dcName :: Name, + dcUnique :: Unique, -- Cached from Name dcTag :: ConTag, @@ -155,7 +210,7 @@ data DataCon -- "Stupid", because the dictionaries aren't used for anything. -- -- Indeed, [as of March 02] they are no - -- longer in the type of the dataConWrapId, because + -- longer in the type of the dcWrapId, because -- that makes it harder to use the wrap-id to rebuild -- values after record selection or in generics. @@ -194,8 +249,11 @@ data DataCon dcWorkId :: Id, -- The corresponding worker Id -- Takes dcRepArgTys as its arguments + -- Perhaps this should be a 'Maybe'; not reqd for newtype constructors - dcWrapId :: Id -- The wrapper Id + dcWrapId :: Maybe Id -- The wrapper Id, if it's necessary + -- It's deemed unnecessary if it performs the + -- identity function } type ConTag = Int @@ -260,25 +318,24 @@ instance Show DataCon where %************************************************************************ \begin{code} -mkDataCon :: Name +mkDataCon :: Name -> [StrictnessMark] -> [FieldLabel] -> [TyVar] -> ThetaType -> [TyVar] -> ThetaType -> [Type] -> TyCon - -> Id -> Id + -> Id -> Maybe Id -- Worker and possible wrapper -> DataCon -- Can get the tag from the TyCon -mkDataCon name arg_stricts fields +mkDataCon name + arg_stricts -- Use [] to mean 'all non-strict' + fields tyvars theta ex_tyvars ex_theta orig_arg_tys tycon work_id wrap_id - = ASSERT(equalLength arg_stricts orig_arg_tys) - -- The 'stricts' passed to mkDataCon are simply those for the - -- source-language arguments. We add extra ones for the - -- dictionary arguments right here. - con + = con where - con = MkData {dcName = name, dcUnique = nameUnique name, + con = MkData {dcName = name, + dcUnique = nameUnique name, dcTyVars = tyvars, dcStupidTheta = theta, dcOrigArgTys = orig_arg_tys, dcRepArgTys = rep_arg_tys, @@ -290,10 +347,15 @@ mkDataCon name arg_stricts fields -- Strictness marks for source-args -- *after unboxing choices*, -- but *including existential dictionaries* + -- + -- The 'arg_stricts' passed to mkDataCon are simply those for the + -- source-language arguments. We add extra ones for the + -- dictionary arguments right here. ex_dict_tys = mkPredTys ex_theta - real_stricts = (map mk_dict_strict_mark ex_dict_tys) ++ - zipWithEqual "mkDataCon1" (chooseBoxingStrategy tycon) - orig_arg_tys arg_stricts + real_stricts = map mk_dict_strict_mark ex_dict_tys ++ + zipWith (chooseBoxingStrategy tycon) + orig_arg_tys + (arg_stricts ++ repeat NotMarkedStrict) real_arg_tys = ex_dict_tys ++ orig_arg_tys -- Representation arguments and demands @@ -326,8 +388,14 @@ dataConRepType = dcRepType dataConWorkId :: DataCon -> Id dataConWorkId = dcWorkId +dataConWrapId_maybe :: DataCon -> Maybe Id +dataConWrapId_maybe = dcWrapId + dataConWrapId :: DataCon -> Id -dataConWrapId = dcWrapId +-- Returns an Id which looks like the Haskell-source constructor +-- If there is no dcWrapId it's because there is no need for a +-- wrapper, so the worker is the Right Thing +dataConWrapId dc = dcWrapId dc `orElse` dcWorkId dc dataConFieldLabels :: DataCon -> [FieldLabel] dataConFieldLabels = dcFields diff --git a/ghc/compiler/basicTypes/Id.lhs b/ghc/compiler/basicTypes/Id.lhs index bd9fffb..8386115 100644 --- a/ghc/compiler/basicTypes/Id.lhs +++ b/ghc/compiler/basicTypes/Id.lhs @@ -29,7 +29,7 @@ module Id ( isRecordSelector, isPrimOpId, isPrimOpId_maybe, isFCallId, isFCallId_maybe, - isDataConId, isDataConId_maybe, + isDataConWorkId, isDataConWorkId_maybe, isDataConWrapId, isDataConWrapId_maybe, isBottomingId, hasNoBinding, @@ -257,13 +257,13 @@ isFCallId_maybe id = case globalIdDetails id of FCallId call -> Just call other -> Nothing -isDataConId id = case globalIdDetails id of - DataConId _ -> True - other -> False +isDataConWorkId id = case globalIdDetails id of + DataConWorkId _ -> True + other -> False -isDataConId_maybe id = case globalIdDetails id of - DataConId con -> Just con - other -> Nothing +isDataConWorkId_maybe id = case globalIdDetails id of + DataConWorkId con -> Just con + other -> Nothing isDataConWrapId_maybe id = case globalIdDetails id of DataConWrapId con -> Just con @@ -292,7 +292,7 @@ isImplicitId id RecordSelId _ -> True -- Includes dictionary selectors FCallId _ -> True PrimOpId _ -> True - DataConId _ -> True + DataConWorkId _ -> True DataConWrapId _ -> True -- These are are implied by their type or class decl; -- remember that all type and class decls appear in the interface file. diff --git a/ghc/compiler/basicTypes/IdInfo.lhs b/ghc/compiler/basicTypes/IdInfo.lhs index 7555cc2..bc38b8c 100644 --- a/ghc/compiler/basicTypes/IdInfo.lhs +++ b/ghc/compiler/basicTypes/IdInfo.lhs @@ -235,7 +235,7 @@ data GlobalIdDetails = VanillaGlobal -- Imported from elsewhere, a default method Id. | RecordSelId FieldLabel -- The Id for a record selector - | DataConId DataCon -- The Id for a data constructor *worker* + | DataConWorkId DataCon -- The Id for a data constructor *worker* | DataConWrapId DataCon -- The Id for a data constructor *wrapper* -- [the only reasons we need to know is so that -- a) we can suppress printing a definition in the interface file @@ -252,7 +252,7 @@ notGlobalId = NotGlobalId instance Outputable GlobalIdDetails where ppr NotGlobalId = ptext SLIT("[***NotGlobalId***]") ppr VanillaGlobal = ptext SLIT("[GlobalId]") - ppr (DataConId _) = ptext SLIT("[DataCon]") + ppr (DataConWorkId _) = ptext SLIT("[DataCon]") ppr (DataConWrapId _) = ptext SLIT("[DataConWrapper]") ppr (PrimOpId _) = ptext SLIT("[PrimOp]") ppr (FCallId _) = ptext SLIT("[ForeignCall]") diff --git a/ghc/compiler/basicTypes/MkId.hi-boot-6 b/ghc/compiler/basicTypes/MkId.hi-boot-6 index 0487ebe..414a4ab 100644 --- a/ghc/compiler/basicTypes/MkId.hi-boot-6 +++ b/ghc/compiler/basicTypes/MkId.hi-boot-6 @@ -1,5 +1,4 @@ module MkId where -mkDataConId :: Name.Name -> DataCon.DataCon -> Var.Id -mkDataConWrapId :: DataCon.DataCon -> Var.Id +mkDataConWorkId :: Name.Name -> DataCon.DataCon -> Var.Id diff --git a/ghc/compiler/basicTypes/MkId.lhs b/ghc/compiler/basicTypes/MkId.lhs index 1299448..8be5844 100644 --- a/ghc/compiler/basicTypes/MkId.lhs +++ b/ghc/compiler/basicTypes/MkId.lhs @@ -16,7 +16,7 @@ module MkId ( mkDictFunId, mkDefaultMethodId, mkDictSelId, - mkDataConId, mkDataConWrapId, + mkDataConWorkId, mkDataConWrapId, mkRecordSelId, mkPrimOpId, mkFCallId, @@ -64,7 +64,7 @@ import DataCon ( DataCon, dataConFieldLabels, dataConRepArity, dataConTyCon, dataConArgTys, dataConRepType, dataConOrigArgTys, - dataConName, dataConTheta, + dataConTheta, dataConSig, dataConStrictMarks, dataConWorkId, splitProductType ) @@ -149,18 +149,18 @@ ghcPrimIds %************************************************************************ \begin{code} -mkDataConId :: Name -> DataCon -> Id +mkDataConWorkId :: Name -> DataCon -> Id -- Makes the *worker* for the data constructor; that is, the function -- that takes the reprsentation arguments and builds the constructor. -mkDataConId work_name data_con - = mkGlobalId (DataConId data_con) work_name (dataConRepType data_con) info +mkDataConWorkId wkr_name data_con + = mkGlobalId (DataConWorkId data_con) wkr_name + (dataConRepType data_con) info where info = noCafIdInfo `setArityInfo` arity `setAllStrictnessInfo` Just strict_sig arity = dataConRepArity data_con - strict_sig = mkStrictSig (mkTopDmdType (replicate arity topDmd) cpr_info) -- Notice that we do *not* say the worker is strict -- even if the data constructor is declared strict @@ -237,18 +237,40 @@ Notice that it in the (common) case where the constructor arg is already evaluated. \begin{code} -mkDataConWrapId data_con - = mkGlobalId (DataConWrapId data_con) (dataConName data_con) wrap_ty info +mkDataConWrapId :: Name -> DataCon -> Maybe Id +-- Only make a wrapper Id if necessary + +mkDataConWrapId wrap_name data_con + | is_newtype || any isMarkedStrict strict_marks + = -- We need a wrapper function + Just (mkGlobalId (DataConWrapId data_con) wrap_name wrap_ty info) + + | otherwise + = Nothing -- The common case, where there is no point in + -- having a wrapper function. Not only is this efficient, + -- but it also ensures that the wrapper is replaced + -- by the worker (becuase it *is* the wroker) + -- even when there are no args. E.g. in + -- f (:) x + -- the (:) *is* the worker. + -- This is really important in rule matching, + -- (We could match on the wrappers, + -- but that makes it less likely that rules will match + -- when we bring bits of unfoldings together.) where - work_id = dataConWorkId data_con + (tyvars, _, ex_tyvars, ex_theta, orig_arg_tys, tycon) = dataConSig data_con + is_newtype = isNewTyCon tycon + all_tyvars = tyvars ++ ex_tyvars + work_id = dataConWorkId data_con - info = noCafIdInfo - `setUnfoldingInfo` wrap_unf - -- The NoCaf-ness is set by noCafIdInfo - `setArityInfo` arity + common_info = noCafIdInfo -- The NoCaf-ness is set by noCafIdInfo + `setArityInfo` arity -- It's important to specify the arity, so that partial -- applications are treated as values - `setAllStrictnessInfo` Just wrap_sig + + info | is_newtype = common_info `setUnfoldingInfo` newtype_unf + | otherwise = common_info `setUnfoldingInfo` data_unf + `setAllStrictnessInfo` Just wrap_sig wrap_sig = mkStrictSig (mkTopDmdType arg_dmds res_info) res_info = strictSigResInfo (idNewStrictness work_id) @@ -264,35 +286,15 @@ mkDataConWrapId data_con -- ...(let w = C x in ...(w p q)...)... -- we want to see that w is strict in its two arguments - wrap_unf | isNewTyCon tycon - = ASSERT( null ex_tyvars && null ex_dict_args && isSingleton orig_arg_tys ) - -- No existentials on a newtype, but it can have a context - -- e.g. newtype Eq a => T a = MkT (...) - mkTopUnfolding $ Note InlineMe $ - mkLams tyvars $ Lam id_arg1 $ - mkNewTypeBody tycon result_ty (Var id_arg1) - - | not (any isMarkedStrict strict_marks) - = mkCompulsoryUnfolding (Var work_id) - -- The common case. Not only is this efficient, - -- but it also ensures that the wrapper is replaced - -- by the worker even when there are no args. - -- f (:) x - -- becomes - -- f $w: x - -- This is really important in rule matching, - -- (We could match on the wrappers, - -- but that makes it less likely that rules will match - -- when we bring bits of unfoldings together.) - -- - -- NB: because of this special case, (map (:) ys) turns into - -- (map $w: ys). The top-level defn for (:) is never used. - -- This is somewhat of a bore, but I'm currently leaving it - -- as is, so that there still is a top level curried (:) for - -- the interpreter to call. - - | otherwise - = mkTopUnfolding $ Note InlineMe $ + newtype_unf = ASSERT( null ex_tyvars && null ex_dict_args && + isSingleton orig_arg_tys ) + -- No existentials on a newtype, but it can have a context + -- e.g. newtype Eq a => T a = MkT (...) + mkTopUnfolding $ Note InlineMe $ + mkLams tyvars $ Lam id_arg1 $ + mkNewTypeBody tycon result_ty (Var id_arg1) + + data_unf = mkTopUnfolding $ Note InlineMe $ mkLams all_tyvars $ mkLams ex_dict_args $ mkLams id_args $ foldr mk_case con_app @@ -301,9 +303,6 @@ mkDataConWrapId data_con con_app i rep_ids = mkApps (Var work_id) (map varToCoreExpr (all_tyvars ++ reverse rep_ids)) - (tyvars, _, ex_tyvars, ex_theta, orig_arg_tys, tycon) = dataConSig data_con - all_tyvars = tyvars ++ ex_tyvars - ex_dict_tys = mkPredTys ex_theta all_arg_tys = ex_dict_tys ++ orig_arg_tys result_ty = mkTyConApp tycon (mkTyVarTys tyvars) diff --git a/ghc/compiler/basicTypes/Name.lhs b/ghc/compiler/basicTypes/Name.lhs index 3a12947..acf518f 100644 --- a/ghc/compiler/basicTypes/Name.lhs +++ b/ghc/compiler/basicTypes/Name.lhs @@ -300,17 +300,13 @@ pprName name@(Name {n_sort = sort, n_uniq = uniq, n_occ = occ}) pprExternal sty name uniq mod occ | codeStyle sty = ppr (moduleName mod) <> char '_' <> pprOccName occ - - | debugStyle sty = ppr (moduleName mod) <> dot <> pprOccName occ <> - text "{-" <> pprUnique uniq <> text "-}" - + | debugStyle sty = ppr (moduleName mod) <> dot <> ppr_debug_occ uniq occ | unqualStyle sty name = pprOccName occ | otherwise = ppr (moduleName mod) <> dot <> pprOccName occ pprInternal sty uniq occ | codeStyle sty = pprUnique uniq - | debugStyle sty = pprOccName occ <> - text "{-" <> pprUnique uniq <> text "-}" + | debugStyle sty = ppr_debug_occ uniq occ | otherwise = pprOccName occ -- User style -- Like Internal, except that we only omit the unique in Iface style @@ -320,6 +316,10 @@ pprSystem sty uniq occ -- If the tidy phase hasn't run, the OccName -- is unlikely to be informative (like 's'), -- so print the unique + +ppr_debug_occ uniq occ = hsep [pprOccName occ, text "{-", + text (briefOccNameFlavour occ), + pprUnique uniq, text "-}"] \end{code} %************************************************************************ diff --git a/ghc/compiler/basicTypes/OccName.lhs b/ghc/compiler/basicTypes/OccName.lhs index e52a090..1ac03b6 100644 --- a/ghc/compiler/basicTypes/OccName.lhs +++ b/ghc/compiler/basicTypes/OccName.lhs @@ -9,7 +9,7 @@ module OccName ( -- The NameSpace type; abstact NameSpace, tcName, clsName, tcClsName, dataName, varName, - tvName, nameSpaceString, + tvName, srcDataName, nameSpaceString, -- The OccName type OccName, -- Abstract, instance of Outputable @@ -20,12 +20,14 @@ module OccName ( mkSuperDictSelOcc, mkDFunOcc, mkForeignExportOcc, mkDictOcc, mkIPOcc, mkWorkerOcc, mkMethodOcc, mkDefaultMethodOcc, mkDerivedTyConOcc, mkClassTyConOcc, mkClassDataConOcc, mkSpecOcc, - mkGenOcc1, mkGenOcc2, mkLocalOcc, + mkGenOcc1, mkGenOcc2, mkLocalOcc, + mkDataConWrapperOcc, mkDataConWorkerOcc, isTvOcc, isTcOcc, isDataOcc, isDataSymOcc, isSymOcc, isValOcc, reportIfUnused, - occNameFS, occNameString, occNameUserString, occNameSpace, occNameFlavour, + occNameFS, occNameString, occNameUserString, occNameSpace, + occNameFlavour, briefOccNameFlavour, setOccNameSpace, -- Tidying up @@ -89,24 +91,44 @@ pprEncodedFS fs %************************************************************************ \begin{code} -data NameSpace = VarName -- Variables - | DataName -- Data constructors +data NameSpace = VarName -- Variables, including "source" data constructors + | DataName -- "Real" data constructors | TvName -- Type variables | TcClsName -- Type constructors and classes; Haskell has them -- in the same name space for now. deriving( Eq, Ord ) {-! derive: Binary !-} +-- Note [Data Constructors] +-- see also: Note [Data Constructor Naming] in DataCon.lhs +-- +-- "Source" data constructors are the data constructors mentioned +-- in Haskell source code +-- +-- "Real" data constructors are the data constructors of the +-- representation type, which may not be the same as the source +-- type + +-- Example: +-- data T = T !(Int,Int) +-- +-- The source datacon has type (Int,Int) -> T +-- The real datacon has type Int -> Int -> T +-- GHC chooses a representation based on the strictness etc. + + -- Though type constructors and classes are in the same name space now, -- the NameSpace type is abstract, so we can easily separate them later tcName = TcClsName -- Type constructors clsName = TcClsName -- Classes tcClsName = TcClsName -- Not sure which! -dataName = DataName -tvName = TvName -varName = VarName +dataName = DataName +srcDataName = DataName -- Haskell-source data constructors should be + -- in the Data name space +tvName = TvName +varName = VarName nameSpaceString :: NameSpace -> String nameSpaceString DataName = "Data constructor" @@ -222,12 +244,22 @@ occNameUserString occ = decode (occNameString occ) occNameSpace :: OccName -> NameSpace occNameSpace (OccName sp _) = sp -setOccNameSpace :: OccName -> NameSpace -> OccName -setOccNameSpace (OccName _ occ) sp = OccName sp occ +setOccNameSpace :: NameSpace -> OccName -> OccName +setOccNameSpace sp (OccName _ occ) = OccName sp occ -- occNameFlavour is used only to generate good error messages occNameFlavour :: OccName -> String -occNameFlavour (OccName sp _) = nameSpaceString sp +occNameFlavour (OccName DataName _) = "Real data constructor" +occNameFlavour (OccName TvName _) = "Type variable" +occNameFlavour (OccName TcClsName _) = "Type constructor or class" +occNameFlavour (OccName VarName s) = "Variable" + +-- briefOccNameFlavour is used in debug-printing of names +briefOccNameFlavour :: OccName -> String +briefOccNameFlavour (OccName DataName _) = "d" +briefOccNameFlavour (OccName VarName _) = "v" +briefOccNameFlavour (OccName TvName _) = "tv" +briefOccNameFlavour (OccName TcClsName _) = "tc" \end{code} \begin{code} @@ -246,9 +278,11 @@ isValOcc other = False -- Data constructor operator (starts with ':', or '[]') -- Pretty inefficient! isDataSymOcc (OccName DataName s) = isLexConSym (decodeFS s) +isDataSymOcc (OccName VarName s) = isLexConSym (decodeFS s) isDataSymOcc other = False isDataOcc (OccName DataName _) = True +isDataOcc (OccName VarName s) = isLexCon (decodeFS s) isDataOcc other = False -- Any operator (data constructor or variable) @@ -315,11 +349,13 @@ mkDictOcc, mkIPOcc, mkWorkerOcc, mkDefaultMethodOcc, :: OccName -> OccName -- These derived variables have a prefix that no Haskell value could have +mkDataConWrapperOcc = mk_simple_deriv varName "$W" mkWorkerOcc = mk_simple_deriv varName "$w" mkDefaultMethodOcc = mk_simple_deriv varName "$dm" mkDerivedTyConOcc = mk_simple_deriv tcName ":" -- The : prefix makes sure it classifies mkClassTyConOcc = mk_simple_deriv tcName ":T" -- as a tycon/datacon -mkClassDataConOcc = mk_simple_deriv dataName ":D" -- +mkClassDataConOcc = mk_simple_deriv dataName ":D" -- We go straight to the "real" data con + -- for datacons from classes mkDictOcc = mk_simple_deriv varName "$d" mkIPOcc = mk_simple_deriv varName "$i" mkSpecOcc = mk_simple_deriv varName "$s" @@ -327,6 +363,12 @@ mkForeignExportOcc = mk_simple_deriv varName "$f" mkGenOcc1 = mk_simple_deriv varName "$gfrom" -- Generics mkGenOcc2 = mk_simple_deriv varName "$gto" -- Generics mk_simple_deriv sp px occ = mk_deriv sp px (occNameString occ) + + +-- Data constructor workers are made by setting the name space +-- of the data constructor OccName (which should be a DataName) +-- to DataName +mkDataConWorkerOcc datacon_occ = setOccNameSpace varName datacon_occ \end{code} \begin{code} diff --git a/ghc/compiler/basicTypes/RdrName.lhs b/ghc/compiler/basicTypes/RdrName.lhs index 9da6edf..1c93ca1 100644 --- a/ghc/compiler/basicTypes/RdrName.lhs +++ b/ghc/compiler/basicTypes/RdrName.lhs @@ -109,10 +109,10 @@ setRdrNameSpace :: RdrName -> NameSpace -> RdrName -- The original-name case *can* occur when parsing -- data [] a = [] | a : [a] -- For the orig-name case we return an unqualified name. -setRdrNameSpace (Unqual occ) ns = Unqual (setOccNameSpace occ ns) -setRdrNameSpace (Qual m occ) ns = Qual m (setOccNameSpace occ ns) -setRdrNameSpace (Orig m occ) ns = Orig m (setOccNameSpace occ ns) -setRdrNameSpace (Exact n) ns = Unqual (setOccNameSpace (nameOccName n) ns) +setRdrNameSpace (Unqual occ) ns = Unqual (setOccNameSpace ns occ) +setRdrNameSpace (Qual m occ) ns = Qual m (setOccNameSpace ns occ) +setRdrNameSpace (Orig m occ) ns = Orig m (setOccNameSpace ns occ) +setRdrNameSpace (Exact n) ns = Unqual (setOccNameSpace ns (nameOccName n)) \end{code} \begin{code} diff --git a/ghc/compiler/codeGen/CgCon.lhs b/ghc/compiler/codeGen/CgCon.lhs index 4fab0e9..324c5cc 100644 --- a/ghc/compiler/codeGen/CgCon.lhs +++ b/ghc/compiler/codeGen/CgCon.lhs @@ -43,7 +43,7 @@ import CostCentre ( currentOrSubsumedCCS, dontCareCCS, CostCentreStack, currentCCS ) import DataCon ( DataCon, dataConTag, isUnboxedTupleCon, isNullaryDataCon, dataConWorkId, - dataConWrapId, dataConRepArity + dataConName, dataConRepArity ) import Id ( Id, idName, idPrimRep ) import Literal ( Literal(..) ) @@ -138,7 +138,7 @@ at all. \begin{code} buildDynCon binder cc con [] = returnFC (stableAmodeIdInfo binder - (CLbl (mkClosureLabel (idName (dataConWrapId con))) PtrRep) + (CLbl (mkClosureLabel (dataConName con)) PtrRep) (mkConLFInfo con)) \end{code} diff --git a/ghc/compiler/coreSyn/CorePrep.lhs b/ghc/compiler/coreSyn/CorePrep.lhs index 1565e55..7ab6894 100644 --- a/ghc/compiler/coreSyn/CorePrep.lhs +++ b/ghc/compiler/coreSyn/CorePrep.lhs @@ -16,16 +16,17 @@ import CoreLint ( endPass ) import CoreSyn import Type ( Type, applyTy, splitFunTy_maybe, isUnLiftedType, isUnboxedTupleType, seqType ) +import TcType ( TyThing( AnId ) ) import NewDemand ( Demand, isStrictDmd, lazyDmd, StrictSig(..), DmdType(..) ) import Var ( Var, Id, setVarUnique ) import VarSet import VarEnv import Id ( mkSysLocal, idType, idNewDemandInfo, idArity, - isFCallId, isGlobalId, + isFCallId, isGlobalId, isImplicitId, isLocalId, hasNoBinding, idNewStrictness, - isDataConId_maybe, idUnfolding + idUnfolding, isDataConWorkId_maybe ) -import HscTypes ( ModGuts(..), ModGuts, implicitTyThingIds, typeEnvElts ) +import HscTypes ( ModGuts(..), ModGuts, typeEnvElts ) import BasicTypes ( TopLevelFlag(..), isTopLevel, isNotTopLevel, RecFlag(..), isNonRec ) @@ -154,14 +155,18 @@ partial applications. But it's easier to let them through. \begin{code} mkImplicitBinds type_env = [ NonRec id (get_unfolding id) - | id <- implicitTyThingIds (typeEnvElts type_env) ] + | AnId id <- typeEnvElts type_env, isImplicitId id ] + -- The type environment already contains all the implicit Ids, + -- so we just filter them out + -- -- The etaExpand is so that the manifest arity of the -- binding matches its claimed arity, which is an -- invariant of top level bindings going into the code gen get_unfolding id -- See notes above - | Just data_con <- isDataConId_maybe id = Var id -- The ice is thin here, but it works - | otherwise = unfoldingTemplate (idUnfolding id) + | Just data_con <- isDataConWorkId_maybe id = Var id -- The ice is thin here, but it works + -- CorePrep will eta-expand it + | otherwise = unfoldingTemplate (idUnfolding id) \end{code} diff --git a/ghc/compiler/coreSyn/CoreUnfold.lhs b/ghc/compiler/coreSyn/CoreUnfold.lhs index c20c22f..46f2ba2 100644 --- a/ghc/compiler/coreSyn/CoreUnfold.lhs +++ b/ghc/compiler/coreSyn/CoreUnfold.lhs @@ -298,7 +298,7 @@ sizeExpr bOMB_OUT_SIZE top_args expr | fun `hasKey` augmentIdKey = augmentSize | otherwise = case globalIdDetails fun of - DataConId dc -> conSizeN dc (valArgCount args) + DataConWorkId dc -> conSizeN dc (valArgCount args) FCallId fc -> sizeN opt_UF_DearOp PrimOpId op -> primOpSize op (valArgCount args) diff --git a/ghc/compiler/coreSyn/CoreUtils.lhs b/ghc/compiler/coreSyn/CoreUtils.lhs index 88c4c70..d2f04c4 100644 --- a/ghc/compiler/coreSyn/CoreUtils.lhs +++ b/ghc/compiler/coreSyn/CoreUtils.lhs @@ -50,7 +50,7 @@ import DataCon ( DataCon, dataConRepArity, dataConArgTys, isExistentialDataCon, import PrimOp ( PrimOp(..), primOpOkForSpeculation, primOpIsCheap ) import Id ( Id, idType, globalIdDetails, idNewStrictness, mkWildId, idArity, idName, idUnfolding, idInfo, isOneShotLambda, - isDataConId_maybe, mkSysLocal, isDataConId, isBottomingId + isDataConWorkId_maybe, mkSysLocal, isDataConWorkId, isBottomingId ) import IdInfo ( GlobalIdDetails(..), megaSeqIdInfo ) @@ -446,10 +446,10 @@ idAppIsCheap id n_val_args -- a variable (f t1 t2 t3) -- counts as WHNF | otherwise = case globalIdDetails id of - DataConId _ -> True - RecordSelId _ -> True -- I'm experimenting with making record selection - -- look cheap, so we will substitute it inside a - -- lambda. Particularly for dictionary field selection + DataConWorkId _ -> True + RecordSelId _ -> True -- I'm experimenting with making record selection + -- look cheap, so we will substitute it inside a + -- lambda. Particularly for dictionary field selection PrimOpId op -> primOpIsCheap op -- In principle we should worry about primops -- that return a type variable, since the result @@ -496,7 +496,7 @@ exprOkForSpeculation other_expr other -> False where - spec_ok (DataConId _) args + spec_ok (DataConWorkId _) args = True -- The strictness of the constructor has already -- been expressed by its "wrapper", so we don't need -- to take the arguments into account @@ -577,7 +577,7 @@ type must be ok-for-speculation (or trivial). \begin{code} exprIsValue :: CoreExpr -> Bool -- True => Value-lambda, constructor, PAP exprIsValue (Var v) -- NB: There are no value args at this point - = isDataConId v -- Catches nullary constructors, + = isDataConWorkId v -- Catches nullary constructors, -- so that [] and () are values, for example || idArity v > 0 -- Catches (e.g.) primops that don't have unfoldings || isEvaldUnfolding (idUnfolding v) @@ -596,7 +596,7 @@ exprIsValue other = False -- There is at least one value argument app_is_value (Var fun) args - | isDataConId fun -- Constructor apps are values + | isDataConWorkId fun -- Constructor apps are values || idArity fun > valArgCount args -- Under-applied function = check_args (idType fun) args app_is_value (App f a) as = app_is_value f (a:as) @@ -665,7 +665,7 @@ exprIsConApp_maybe (Note _ expr) exprIsConApp_maybe expr = analyse (collectArgs expr) where analyse (Var fun, args) - | Just con <- isDataConId_maybe fun, + | Just con <- isDataConWorkId_maybe fun, args `lengthAtLeast` dataConRepArity con -- Might be > because the arity excludes type args = Just (con,args) diff --git a/ghc/compiler/coreSyn/MkExternalCore.lhs b/ghc/compiler/coreSyn/MkExternalCore.lhs index a5d1751..2b32348 100644 --- a/ghc/compiler/coreSyn/MkExternalCore.lhs +++ b/ghc/compiler/coreSyn/MkExternalCore.lhs @@ -18,13 +18,14 @@ import TyCon import Class import TypeRep import Type -import DataCon +import DataCon ( DataCon, dataConExistentialTyVars, dataConRepArgTys, + dataConName, dataConWrapId_maybe ) import CoreSyn import Var import IdInfo -import Id( idUnfolding ) -import CoreTidy( tidyExpr ) -import VarEnv( emptyTidyEnv ) +import Id ( idUnfolding ) +import CoreTidy ( tidyExpr ) +import VarEnv ( emptyTidyEnv ) import Literal import Name import CostCentre @@ -32,7 +33,7 @@ import Outputable import ForeignCall import PprExternalCore import CmdLineOpts -import Maybes( orElse ) +import Maybes ( orElse, catMaybes ) import IO import FastString @@ -72,8 +73,8 @@ mkExternalCore (ModGuts {mg_module=this_mod, mg_types = type_env, mg_binds = bin other_implicit_binds = map get_defn (concatMap other_implicit_ids (typeEnvElts type_env)) implicit_con_ids :: TyThing -> [Id] -implicit_con_ids (ATyCon tc) = map dataConWrapId (tyConDataCons_maybe tc `orElse` []) -implicit_con_ids other = [] +implicit_con_ids (ATyCon tc) | isAlgTyCon tc = catMaybes (map dataConWrapId_maybe (tyConDataCons tc)) +implicit_con_ids other = [] other_implicit_ids :: TyThing -> [Id] other_implicit_ids (ATyCon tc) = tyConSelIds tc ++ tyConGenIds tc diff --git a/ghc/compiler/coreSyn/PprCore.lhs b/ghc/compiler/coreSyn/PprCore.lhs index 061975e..7c9494e 100644 --- a/ghc/compiler/coreSyn/PprCore.lhs +++ b/ghc/compiler/coreSyn/PprCore.lhs @@ -19,7 +19,7 @@ module PprCore ( import CoreSyn import CostCentre ( pprCostCentreCore ) import Var ( Var ) -import Id ( Id, idType, isDataConId_maybe, idLBVarInfo, idArity, +import Id ( Id, idType, isDataConWorkId_maybe, idLBVarInfo, idArity, idInfo, idInlinePragma, idOccInfo, #ifdef OLD_STRICTNESS idDemandInfo, @@ -138,7 +138,7 @@ ppr_expr add_par expr@(App fun arg) pp_tup_args = sep (punctuate comma (map pprArg val_args)) in case fun of - Var f -> case isDataConId_maybe f of + Var f -> case isDataConWorkId_maybe f of -- Notice that we print the *worker* -- for tuples in paren'd format. Just dc | saturated && isTupleTyCon tc diff --git a/ghc/compiler/deSugar/DsMeta.hs b/ghc/compiler/deSugar/DsMeta.hs index 79a61a4..d4b14d4 100644 --- a/ghc/compiler/deSugar/DsMeta.hs +++ b/ghc/compiler/deSugar/DsMeta.hs @@ -59,8 +59,8 @@ import Name ( mkKnownKeyExternalName ) import OccName ( mkOccFS ) import NameEnv import NameSet -import Type ( Type, TyThing(..), mkGenTyConApp ) -import TcType ( tcTyConAppArgs ) +import Type ( Type, mkGenTyConApp ) +import TcType ( TyThing(..), tcTyConAppArgs ) import TyCon ( DataConDetails(..) ) import TysWiredIn ( stringTy ) import CoreSyn diff --git a/ghc/compiler/ghci/ByteCodeGen.lhs b/ghc/compiler/ghci/ByteCodeGen.lhs index d367bec..367326e 100644 --- a/ghc/compiler/ghci/ByteCodeGen.lhs +++ b/ghc/compiler/ghci/ByteCodeGen.lhs @@ -31,7 +31,7 @@ import Type ( typePrimRep, isUnLiftedType, splitTyConApp_maybe, isTyVarTy ) import DataCon ( DataCon, dataConTag, fIRST_TAG, dataConTyCon, isUnboxedTupleCon, isNullaryDataCon, - dataConRepArity, dataConWorkId ) + dataConRepArity ) import TyCon ( tyConFamilySize, isDataTyCon, tyConDataCons, isFunTyCon, isUnboxedTupleTyCon ) import Class ( Class, classTyCon ) @@ -239,7 +239,7 @@ schemeTopBind :: (Id, AnnExpr Id VarSet) -> BcM (ProtoBCO Name) schemeTopBind (id, rhs) - | Just data_con <- isDataConId_maybe id, + | Just data_con <- isDataConWorkId_maybe id, isNullaryDataCon data_con = -- Special case for the worker of a nullary data con. -- It'll look like this: $wNil = /\a -> $wNil a @@ -360,7 +360,7 @@ schemeE d s p (AnnLit literal) schemeE d s p (AnnLet (AnnNonRec x (_,rhs)) (_,body)) | (AnnVar v, args_r_to_l) <- splitApp rhs, - Just data_con <- isDataConId_maybe v, + Just data_con <- isDataConWorkId_maybe v, dataConRepArity data_con == length args_r_to_l = -- Special case for a non-recursive let whose RHS is a -- saturatred constructor application. @@ -554,7 +554,7 @@ schemeT d s p app -- saturated. Otherwise, we'll call the constructor wrapper. n_args = length args_r_to_l maybe_saturated_dcon - = case isDataConId_maybe fn of + = case isDataConWorkId_maybe fn of Just con | dataConRepArity con == n_args -> Just con _ -> Nothing @@ -569,10 +569,9 @@ mkConAppCode :: Int -> Sequel -> BCEnv mkConAppCode orig_d s p con [] -- Nullary constructor = ASSERT( isNullaryDataCon con ) - returnBc (unitOL (PUSH_G (getName (dataConWorkId con)))) + returnBc (unitOL (PUSH_G (getName con))) -- Instead of doing a PACK, which would allocate a fresh -- copy of this constructor, use the single shared version. - -- The name of the constructor is the name of its wrapper function mkConAppCode orig_d s p con args_r_to_l = ASSERT( dataConRepArity con == length args_r_to_l ) diff --git a/ghc/compiler/ghci/InteractiveUI.hs b/ghc/compiler/ghci/InteractiveUI.hs index 3cfd5d2..7f17397 100644 --- a/ghc/compiler/ghci/InteractiveUI.hs +++ b/ghc/compiler/ghci/InteractiveUI.hs @@ -1,6 +1,6 @@ {-# OPTIONS -#include "Linker.h" #-} ----------------------------------------------------------------------------- --- $Id: InteractiveUI.hs,v 1.142 2002/12/27 12:20:06 panne Exp $ +-- $Id: InteractiveUI.hs,v 1.143 2003/02/12 15:01:35 simonpj Exp $ -- -- GHC Interactive User Interface -- @@ -26,10 +26,10 @@ import DriverUtil ( remove_spaces, handle ) import Linker ( initLinker, showLinkerState, linkLibraries, linkPackages ) import Util -import Id ( isRecordSelector, recordSelectorFieldLabel, - isDataConWrapId, isDataConId, idName ) +import Id ( isRecordSelector, isImplicitId, recordSelectorFieldLabel, idName ) import Class ( className ) import TyCon ( tyConName, tyConClass_maybe, isPrimTyCon, DataConDetails(..) ) +import DataCon ( dataConName ) import FieldLabel ( fieldLabelTyCon ) import SrcLoc ( isGoodSrcLoc ) import Module ( showModMsg, lookupModuleEnv ) @@ -497,6 +497,8 @@ info s = do showTyThing (AClass cl) = hcat [ppr cl, text " is a class", showSrcLoc (className cl)] + showTyThing (ADataCon dc) + = hcat [ppr dc, text " is a data constructor", showSrcLoc (dataConName dc)] showTyThing (ATyCon ty) | isPrimTyCon ty = hcat [ppr ty, text " is a primitive type constructor"] @@ -511,7 +513,6 @@ info s = do recordSelectorFieldLabel id)) of Nothing -> text "record selector" Just c -> text "method in class " <> ppr c - | isDataConWrapId id = text "data constructor" | otherwise = text "variable" -- also print out the source location for home things @@ -702,8 +703,9 @@ browseModule m exports_only = do things' = filter wantToSee things - wantToSee (AnId id) = not (isDataConId id || isDataConWrapId id) - wantToSee _ = True + wantToSee (AnId id) = not (isImplicitId id) + wantToSee (ADataCon _) = False -- They'll come via their TyCon + wantToSee _ = True thing_names = map getName things diff --git a/ghc/compiler/hsSyn/Convert.lhs b/ghc/compiler/hsSyn/Convert.lhs index 9dbf8de..3d9996f 100644 --- a/ghc/compiler/hsSyn/Convert.lhs +++ b/ghc/compiler/hsSyn/Convert.lhs @@ -62,7 +62,7 @@ cvt_top (Data tc tvs constrs derivs) where mk_con (Constr c tys) = ConDecl (cName c) noExistentials noContext - (PrefixCon (map mk_arg tys)) loc0 + (PrefixCon (map mk_arg tys)) loc0 mk_arg ty = BangType NotMarkedStrict (cvtType ty) @@ -150,8 +150,8 @@ noFunDeps = [] convertToHsExpr :: Meta.Exp -> HsExpr RdrName convertToHsExpr = cvt -cvt (Var s) = HsVar(vName s) -cvt (Con s) = HsVar(cName s) +cvt (Var s) = HsVar (vName s) +cvt (Con s) = HsVar (cName s) cvt (Lit l) | overloadedLit l = HsOverLit (cvtOverLit l) | otherwise = HsLit (cvtLit l) @@ -332,9 +332,9 @@ loc0 = generatedSrcLoc vName :: String -> RdrName vName = mkName varName --- Constructor function names +-- Constructor function names; this is Haskell source, hence srcDataName cName :: String -> RdrName -cName = mkName dataName +cName = mkName srcDataName -- Type variable names tName :: String -> RdrName diff --git a/ghc/compiler/hsSyn/HsCore.lhs b/ghc/compiler/hsSyn/HsCore.lhs index 1174278..e73c4a4 100644 --- a/ghc/compiler/hsSyn/HsCore.lhs +++ b/ghc/compiler/hsSyn/HsCore.lhs @@ -31,7 +31,7 @@ import HsTypes ( HsType, pprParendHsType, pprHsTyVarBndr, toHsType, ) -- others: -import Id ( idArity, idType, isDataConId_maybe, isFCallId_maybe ) +import Id ( idArity, idType, isDataConWorkId_maybe, isFCallId_maybe ) import Var ( varType, isId ) import IdInfo ( InlinePragInfo ) import Name ( Name, NamedThing(..), eqNameByOcc ) @@ -153,7 +153,7 @@ toUfBndr x | isId x = UfValBinder (getName x) (toHsType (varType x)) --------------------- toUfApp (App f a) as = toUfApp f (a:as) toUfApp (Var v) as - = case isDataConId_maybe v of + = case isDataConWorkId_maybe v of -- We convert the *worker* for tuples into UfTuples Just dc | isTupleTyCon tc && saturated -> UfTuple (mk_hs_tup_con tc dc) tup_args diff --git a/ghc/compiler/javaGen/JavaGen.lhs b/ghc/compiler/javaGen/JavaGen.lhs index 55b2b71..ff0dd91 100644 --- a/ghc/compiler/javaGen/JavaGen.lhs +++ b/ghc/compiler/javaGen/JavaGen.lhs @@ -47,7 +47,7 @@ module JavaGen( javaGen ) where import Java import Literal ( Literal(..) ) -import Id ( Id, isDataConId_maybe, isId, idName, isDeadBinder, idPrimRep +import Id ( Id, isDataConWorkId_maybe, isId, idName, isDeadBinder, idPrimRep , isPrimOpId_maybe ) import Name ( NamedThing(..), getOccString, isExternalName, isInternalName , nameModule ) @@ -420,7 +420,7 @@ javaApp r (CoreSyn.App f a) as | isValArg a = javaApp r f (a:as) | otherwise = javaApp r f as javaApp r (CoreSyn.Var f) as - = case isDataConId_maybe f of { + = case isDataConWorkId_maybe f of { Just dc | as `lengthIs` dataConRepArity dc -- NOTE: Saturated constructors never returning a primitive at this point -- diff --git a/ghc/compiler/main/HscTypes.lhs b/ghc/compiler/main/HscTypes.lhs index 89a854c..88248a0 100644 --- a/ghc/compiler/main/HscTypes.lhs +++ b/ghc/compiler/main/HscTypes.lhs @@ -26,7 +26,7 @@ module HscTypes ( VersionInfo(..), initialVersionInfo, lookupVersion, FixityEnv, lookupFixity, collectFixities, emptyFixityEnv, - TyThing(..), isTyClThing, implicitTyThingIds, + TyThing(..), implicitTyThings, TypeEnv, lookupType, mkTypeEnv, emptyTypeEnv, extendTypeEnvList, extendTypeEnvWithIds, @@ -78,11 +78,11 @@ import Module import InstEnv ( InstEnv, ClsInstEnv, DFunId ) import Rules ( RuleBase ) import CoreSyn ( CoreBind ) -import Id ( Id ) -import Class ( Class, classSelIds ) -import TyCon ( TyCon, isNewTyCon, tyConGenIds, tyConSelIds, tyConDataCons_maybe ) -import Type ( TyThing(..), isTyClThing ) -import DataCon ( dataConWorkId, dataConWrapId ) +import Id ( Id, idName ) +import Class ( Class, classSelIds, classTyCon ) +import TyCon ( TyCon, tyConName, isNewTyCon, tyConGenIds, tyConSelIds, tyConDataCons ) +import TcType ( TyThing(..) ) +import DataCon ( dataConWorkId, dataConWrapId, dataConWrapId_maybe ) import Packages ( PackageName, basePackage ) import CmdLineOpts ( DynFlags ) @@ -423,24 +423,6 @@ typeEnvElts env = nameEnvElts env typeEnvClasses env = [cl | AClass cl <- typeEnvElts env] typeEnvTyCons env = [tc | ATyCon tc <- typeEnvElts env] typeEnvIds env = [id | AnId id <- typeEnvElts env] - -implicitTyThingIds :: [TyThing] -> [Id] --- Add the implicit data cons and selectors etc -implicitTyThingIds things - = concat (map go things) - where - go (AnId f) = [] - go (AClass cl) = classSelIds cl - go (ATyCon tc) = tyConGenIds tc ++ - tyConSelIds tc ++ - [ n | dc <- tyConDataCons_maybe tc `orElse` [], - n <- implicitConIds tc dc] - -- Synonyms return empty list of constructors and selectors - - implicitConIds tc dc -- Newtypes have a constructor wrapper, - -- but no worker - | isNewTyCon tc = [dataConWrapId dc] - | otherwise = [dataConWorkId dc, dataConWrapId dc] \end{code} @@ -453,8 +435,45 @@ mkTypeEnv :: [TyThing] -> TypeEnv mkTypeEnv things = extendTypeEnvList emptyTypeEnv things extendTypeEnvList :: TypeEnv -> [TyThing] -> TypeEnv +-- Extend the type environment extendTypeEnvList env things - = extendNameEnvList env [(getName thing, thing) | thing <- things] + = foldl extend env things + where + extend env thing = extendNameEnv env (getName thing) thing + +implicitTyThings :: [TyThing] -> [TyThing] +implicitTyThings things + = concatMap extras things + where + extras_plus thing = thing : extras thing + + extras (AnId id) = [] + + -- For type constructors, add the data cons (and their extras), + -- and the selectors and generic-programming Ids too + -- + -- Newtypes don't have a worker Id, so don't generate that + extras (ATyCon tc) = map AnId (tyConGenIds tc ++ tyConSelIds tc) ++ data_con_stuff + where + data_con_stuff | isNewTyCon tc = [ADataCon dc1, AnId (dataConWrapId dc1)] + | otherwise = concatMap (extras_plus . ADataCon) dcs + dcs = tyConDataCons tc + dc1 = head dcs + + -- For classes, add the class TyCon too (and its extras) + -- and the class selector Ids + extras (AClass cl) = map AnId (classSelIds cl) ++ + extras_plus (ATyCon (classTyCon cl)) + + + -- For data cons add the worker and wrapper (if any) + extras (ADataCon dc) + = AnId (dataConWorkId dc) : wrap_id_stuff + where + -- May or may not have a wrapper + wrap_id_stuff = case dataConWrapId_maybe dc of + Just id -> [AnId id] + Nothing -> [] extendTypeEnvWithIds :: TypeEnv -> [Id] -> TypeEnv extendTypeEnvWithIds env ids diff --git a/ghc/compiler/main/MkIface.lhs b/ghc/compiler/main/MkIface.lhs index 899d0df..2b35f37 100644 --- a/ghc/compiler/main/MkIface.lhs +++ b/ghc/compiler/main/MkIface.lhs @@ -39,7 +39,7 @@ import HscTypes ( VersionInfo(..), ModIface(..), import CmdLineOpts import Id ( idType, idInfo, isImplicitId, idCgInfo ) -import DataCon ( dataConSig, dataConFieldLabels, dataConStrictMarks ) +import DataCon ( dataConName, dataConSig, dataConFieldLabels, dataConStrictMarks ) import IdInfo -- Lots import CoreSyn ( CoreRule(..), IdCoreRule ) import CoreFVs ( ruleLhsFreeNames ) @@ -224,6 +224,7 @@ we miss them out of the accumulating parameter here. \begin{code} ifaceTyThing_acc :: TyThing -> [RenamedTyClDecl] -> [RenamedTyClDecl] +ifaceTyThing_acc (ADataCon dc) so_far = so_far ifaceTyThing_acc (AnId id) so_far | isImplicitId id = so_far ifaceTyThing_acc (ATyCon id) so_far | isClassTyCon id = so_far ifaceTyThing_acc other so_far = ifaceTyThing other : so_far @@ -308,7 +309,7 @@ ifaceTyThing (ATyCon tycon) = ty_decl ifaceConDecls (DataCons cs) = DataCons (map ifaceConDecl cs) ifaceConDecl data_con - = ConDecl (getName data_con) + = ConDecl (dataConName data_con) (toHsTyVars ex_tyvars) (toHsContext ex_theta) details noSrcLoc diff --git a/ghc/compiler/nativeGen/AbsCStixGen.lhs b/ghc/compiler/nativeGen/AbsCStixGen.lhs index 5bc8073..05e0a5d 100644 --- a/ghc/compiler/nativeGen/AbsCStixGen.lhs +++ b/ghc/compiler/nativeGen/AbsCStixGen.lhs @@ -35,7 +35,6 @@ import Util ( naturalMergeSortLe ) import Panic ( panic ) import TyCon ( tyConDataCons ) import Constants ( wORD_SIZE, bITMAP_BITS_SHIFT ) -import DataCon ( dataConWrapId ) import Name ( NamedThing(..) ) import CmdLineOpts ( opt_Static, opt_EnsureSplittableC ) import Outputable ( assertPanic ) @@ -156,7 +155,7 @@ Here we handle top-level things, like @CCodeBlock@s and gentopcode stmt@(CClosureTbl tycon) = returnUs [ StSegment TextSegment , StLabel (mkClosureTblLabel tycon) - , StData DataPtrRep (map (StCLbl . mkClosureLabel . getName . dataConWrapId) + , StData DataPtrRep (map (StCLbl . mkClosureLabel . getName) (tyConDataCons tycon) ) ] diff --git a/ghc/compiler/parser/Parser.y b/ghc/compiler/parser/Parser.y index 907c929..be85b31 100644 --- a/ghc/compiler/parser/Parser.y +++ b/ghc/compiler/parser/Parser.y @@ -1,6 +1,6 @@ {- -*-haskell-*- ----------------------------------------------------------------------------- -$Id: Parser.y,v 1.114 2002/12/10 16:28:48 igloo Exp $ +$Id: Parser.y,v 1.115 2003/02/12 15:01:37 simonpj Exp $ Haskell grammar. @@ -21,13 +21,14 @@ import HscTypes ( ParsedIface(..), IsBootInterface, noDependencies ) import Lex import RdrName import PrelNames ( mAIN_Name, funTyConName, listTyConName, - parrTyConName, consDataConName, nilDataConName ) -import TysWiredIn ( unitTyCon, unitDataCon, tupleTyCon, tupleCon ) + parrTyConName, consDataConName ) +import TysWiredIn ( unitTyCon, unitDataCon, tupleTyCon, tupleCon, nilDataCon ) import ForeignCall ( Safety(..), CExportSpec(..), CCallConv(..), CCallTarget(..), defaultCCallConv, ) import OccName ( UserFS, varName, tcName, dataName, tcClsName, tvName ) import TyCon ( DataConDetails(..) ) +import DataCon ( DataCon, dataConName ) import SrcLoc ( SrcLoc ) import Module import CmdLineOpts ( opt_SccProfilingOn, opt_InPackage ) @@ -1209,14 +1210,14 @@ deprec_var : var { $1 } | tycon { $1 } gcon :: { RdrName } -- Data constructor namespace - : sysdcon { $1 } + : sysdcon { nameRdrName (dataConName $1) } | qcon { $1 } -- the case of '[:' ':]' is part of the production `parr' -sysdcon :: { RdrName } -- Data constructor namespace - : '(' ')' { getRdrName unitDataCon } - | '(' commas ')' { getRdrName (tupleCon Boxed $2) } - | '[' ']' { nameRdrName nilDataConName } +sysdcon :: { DataCon } -- Wired in data constructors + : '(' ')' { unitDataCon } + | '(' commas ')' { tupleCon Boxed $2 } + | '[' ']' { nilDataCon } var :: { RdrName } : varid { $1 } @@ -1394,8 +1395,10 @@ qconsym :: { RdrName } -- Qualified or unqualified consym :: { RdrName } : CONSYM { mkUnqual dataName $1 } - | ':' { nameRdrName consDataConName } + -- ':' means only list cons + | ':' { nameRdrName consDataConName } + -- NB: SrcName because we are reading source ----------------------------------------------------------------------------- diff --git a/ghc/compiler/parser/ParserCore.y b/ghc/compiler/parser/ParserCore.y index a249ac6..9318892 100644 --- a/ghc/compiler/parser/ParserCore.y +++ b/ghc/compiler/parser/ParserCore.y @@ -150,7 +150,7 @@ cons1 :: { [ConDecl RdrName] } | con ';' cons1 { $1:$3 } con :: { ConDecl RdrName } - : q_d_name attbinds atys + : q_d_patt attbinds atys { ConDecl $1 $2 [] (PrefixCon (map unbangedType $3)) noSrcLoc} atys :: { [ RdrNameHsType] } @@ -202,8 +202,8 @@ alts1 :: { [UfAlt RdrName] } | alt ';' alts1 { $1:$3 } alt :: { UfAlt RdrName } - : q_d_name attbinds vbinds '->' exp - { {- ToDo: sort out-} (UfDataAlt $1, (map hsTyVarName $2 ++ map fst $3), $5) } + : q_d_patt attbinds vbinds '->' exp + { (UfDataAlt $1, (map hsTyVarName $2 ++ map fst $3), $5) } | lit '->' exp { (UfLitAlt $1, [], $3) } | '%_' '->' exp @@ -211,7 +211,7 @@ alt :: { UfAlt RdrName } lit :: { Literal } : '(' INTEGER '::' aty ')' { convIntLit $2 $4 } - | '(' RATIONAL '::' aty ')' { MachDouble $2 } + | '(' RATIONAL '::' aty ')' { convRatLit $2 $4 } | '(' CHAR '::' aty ')' { MachChar (fromEnum $2) } | '(' STRING '::' aty ')' { MachStr (mkFastString $2) } @@ -230,7 +230,7 @@ modid :: { ModuleName } qname :: { RdrName } -- Includes data constructors : name { $1 } | mname '.' NAME { mkIfaceOrig varName (mkFastString $1) (mkFastString $3) } - | q_d_name { $1 } + | q_d_occ { $1 } -- Type constructor @@ -238,11 +238,18 @@ q_tc_name :: { RdrName } : mname '.' cname { mkIfaceOrig tcName (mkFastString $1) (mkFastString $3) } --- Data constructor -q_d_name :: { RdrName } +-- Data constructor in a pattern or data type declaration; use the dataName, +-- because that's what we expect in Core case patterns +q_d_patt :: { RdrName } : mname '.' cname { mkIfaceOrig dataName (mkFastString $1) (mkFastString $3) } +-- Data constructor occurrence in an expression; +-- use the varName because that's the worker Id +q_d_occ :: { RdrName } + : mname '.' cname + { mkIfaceOrig varName (mkFastString $1) (mkFastString $3) } + { convBind :: RdrNameCoreDecl -> (UfBinder RdrName, UfExpr RdrName) @@ -253,13 +260,21 @@ convIntLit i (HsTyVar n) | n == intPrimRdrName = MachInt i | n == wordPrimRdrName = MachWord i convIntLit i aty - = pprPanic "Unknown literal type" (ppr aty $$ ppr intPrimRdrName) + = pprPanic "Unknown integer literal type" (ppr aty $$ ppr intPrimRdrName) + +convRatLit :: Rational -> RdrNameHsType -> Literal +convRatLit r (HsTyVar n) + | n == floatPrimRdrName = MachFloat r + | n == doublePrimRdrName = MachDouble r +convRatLit i aty + = pprPanic "Unknown rational literal type" (ppr aty $$ ppr intPrimRdrName) -wordPrimRdrName :: RdrName -wordPrimRdrName = nameRdrName wordPrimTyConName -intPrimRdrName :: RdrName -intPrimRdrName = nameRdrName intPrimTyConName +wordPrimRdrName, intPrimRdrName, floatPrimRdrName, doublePrimRdrName :: RdrName +wordPrimRdrName = nameRdrName wordPrimTyConName +intPrimRdrName = nameRdrName intPrimTyConName +floatPrimRdrName = nameRdrName floatPrimTyConName +doublePrimRdrName = nameRdrName doublePrimTyConName happyError :: P a happyError s l = failP (show l ++ ": Parse error\n") (take 100 s) l diff --git a/ghc/compiler/parser/RdrHsSyn.lhs b/ghc/compiler/parser/RdrHsSyn.lhs index 6cf8adb..729b416 100644 --- a/ghc/compiler/parser/RdrHsSyn.lhs +++ b/ghc/compiler/parser/RdrHsSyn.lhs @@ -101,7 +101,7 @@ import HscTypes ( RdrAvailInfo, GenAvailInfo(..) ) import TysWiredIn ( unitTyCon ) import ForeignCall ( CCallConv, Safety, CCallTarget(..), CExportSpec(..), DNCallSpec(..)) -import OccName ( dataName, varName, isDataOcc, isTcOcc, occNameUserString, +import OccName ( srcDataName, varName, isDataOcc, isTcOcc, occNameUserString, mkDefaultMethodOcc, mkVarOcc ) import SrcLoc import CStrings ( CLabelString ) @@ -496,7 +496,7 @@ mkRecCon con fields tyConToDataCon :: RdrName -> P RdrName tyConToDataCon tc | isTcOcc (rdrNameOcc tc) - = returnP (setRdrNameSpace tc dataName) + = returnP (setRdrNameSpace tc srcDataName) | otherwise = parseError (showSDoc (text "Not a constructor:" <+> quotes (ppr tc))) diff --git a/ghc/compiler/prelude/PrelInfo.lhs b/ghc/compiler/prelude/PrelInfo.lhs index 92c898b..9e28920 100644 --- a/ghc/compiler/prelude/PrelInfo.lhs +++ b/ghc/compiler/prelude/PrelInfo.lhs @@ -47,7 +47,7 @@ import OccName ( mkVarOcc ) import TysPrim ( primTyCons ) import TysWiredIn ( wiredInTyCons ) import RdrHsSyn ( mkClassDecl ) -import HscTypes ( TyThing(..), implicitTyThingIds, TypeEnv, mkTypeEnv, +import HscTypes ( TyThing(..), implicitTyThings, TypeEnv, mkTypeEnv, GenAvailInfo(..), RdrAvailInfo ) import Class ( Class, classKey, className ) import Type ( funTyCon, openTypeKind, liftedTypeKind ) @@ -71,7 +71,7 @@ wiredInThings = concat [ -- Wired in TyCons and their implicit Ids tycon_things - , map AnId (implicitTyThingIds tycon_things) + , implicitTyThings tycon_things -- Wired in Ids , map AnId wiredInIds diff --git a/ghc/compiler/prelude/PrelNames.lhs b/ghc/compiler/prelude/PrelNames.lhs index 35d65dd..bf26ca0 100644 --- a/ghc/compiler/prelude/PrelNames.lhs +++ b/ghc/compiler/prelude/PrelNames.lhs @@ -684,7 +684,8 @@ All these are original names; hence mkOrig \begin{code} varQual = mk_known_key_name varName -dataQual = mk_known_key_name dataName +dataQual = mk_known_key_name dataName -- All the constructor names here are for the DataCon + -- itself, which lives in the VarName name space tcQual = mk_known_key_name tcName clsQual = mk_known_key_name clsName @@ -692,10 +693,10 @@ wVarQual = mk_wired_in_name varName -- The wired-in analogues wDataQual = mk_wired_in_name dataName wTcQual = mk_wired_in_name tcName -varQual_RDR mod str = mkOrig mod (mkOccFS varName str) -- note use of local alias vName +varQual_RDR mod str = mkOrig mod (mkOccFS varName str) -- The RDR analogues +dataQual_RDR mod str = mkOrig mod (mkOccFS dataName str) tcQual_RDR mod str = mkOrig mod (mkOccFS tcName str) clsQual_RDR mod str = mkOrig mod (mkOccFS clsName str) -dataQual_RDR mod str = mkOrig mod (mkOccFS dataName str) mk_known_key_name space mod str uniq = mkKnownKeyExternalName (mkBasePkgModule mod) (mkOccFS space str) uniq diff --git a/ghc/compiler/prelude/TysWiredIn.lhs b/ghc/compiler/prelude/TysWiredIn.lhs index 5b6754e..8855085 100644 --- a/ghc/compiler/prelude/TysWiredIn.lhs +++ b/ghc/compiler/prelude/TysWiredIn.lhs @@ -78,7 +78,7 @@ module TysWiredIn ( #include "HsVersions.h" -import {-# SOURCE #-} MkId( mkDataConId, mkDataConWrapId ) +import {-# SOURCE #-} MkId( mkDataConWorkId ) import {-# SOURCE #-} Generics( mkTyConGenInfo ) -- friends: @@ -90,7 +90,7 @@ import Constants ( mAX_TUPLE_SIZE ) import Module ( mkBasePkgModule ) import Name ( Name, nameUnique, nameOccName, nameModule, mkWiredInName ) -import OccName ( mkOccFS, tcName, dataName, mkWorkerOcc, mkGenOcc1, mkGenOcc2 ) +import OccName ( mkOccFS, tcName, dataName, mkDataConWorkerOcc, mkGenOcc1, mkGenOcc2 ) import DataCon ( DataCon, mkDataCon, dataConWorkId, dataConSourceArity ) import Var ( TyVar, tyVarKind ) import TyCon ( TyCon, AlgTyConFlavour(..), DataConDetails(..), tyConDataCons, @@ -192,27 +192,28 @@ mk_tc_gen_info mod tc_uniq tc_name tycon name2 = mkWiredInName mod occ_name2 fn2_key pcDataCon :: Name -> [TyVar] -> ThetaType -> [Type] -> TyCon -> DataCon +-- The Name should be in the DataName name space; it's the name +-- of the DataCon itself. +-- -- The unique is the first of two free uniques; --- the first is used for the datacon itself and the worker; --- the second is used for the wrapper. +-- the first is used for the datacon itself, +-- the second is used for the "worker name" -pcDataCon name tyvars context arg_tys tycon +pcDataCon dc_name tyvars context arg_tys tycon = data_con where - data_con = mkDataCon name - [ NotMarkedStrict | a <- arg_tys ] - [ {- no labelled fields -} ] - tyvars context [] [] arg_tys tycon work_id wrap_id - - wrap_occ = nameOccName name - - mod = nameModule name - wrap_id = mkDataConWrapId data_con - - work_occ = mkWorkerOcc wrap_occ - work_key = incrUnique (nameUnique name) - work_name = mkWiredInName mod work_occ work_key - work_id = mkDataConId work_name data_con + data_con = mkDataCon dc_name + [{- No strictness -}] + [{- No labelled fields -}] + tyvars context [] [] arg_tys tycon work_id + Nothing {- No wrapper for wired-in things + (they are too simple to need one) -} + + mod = nameModule dc_name + wrk_occ = mkDataConWorkerOcc (nameOccName dc_name) + wrk_key = incrUnique (nameUnique dc_name) + wrk_name = mkWiredInName mod wrk_occ wrk_key + work_id = mkDataConWorkId wrk_name data_con \end{code} diff --git a/ghc/compiler/rename/RnHiFiles.lhs b/ghc/compiler/rename/RnHiFiles.lhs index e5f83a5..c6ddc2c 100644 --- a/ghc/compiler/rename/RnHiFiles.lhs +++ b/ghc/compiler/rename/RnHiFiles.lhs @@ -53,7 +53,8 @@ import Module ( Module, ModuleName, ModLocation(ml_hi_file), ) import RdrName ( RdrName, mkRdrUnqual, rdrNameOcc, nameRdrName ) import OccName ( OccName, mkWorkerOcc, mkClassTyConOcc, mkClassDataConOcc, - mkSuperDictSelOcc, mkGenOcc1, mkGenOcc2 ) + mkSuperDictSelOcc, mkGenOcc1, mkGenOcc2, + mkDataConWrapperOcc, mkDataConWorkerOcc ) import TyCon ( DataConDetails(..) ) import SrcLoc ( noSrcLoc, mkSrcLoc ) import Maybes ( maybeToBool ) @@ -326,13 +327,14 @@ getSysBinders :: Module -> TyClDecl RdrName -> TcRn m [Name] -- on RdrNames, returning OccNames getSysBinders mod (ClassDecl {tcdName = cname, tcdCtxt = cxt, tcdLoc = loc}) - = sequenceM [new_sys_bndr mod n loc | n <- sys_occs] + = mapM (new_sys_bndr mod loc) sys_occs where -- C.f. TcClassDcl.tcClassDecl1 - sys_occs = tc_occ : data_occ : dw_occ : sc_sel_occs + sys_occs = tc_occ : data_occ : dwrap_occ : dwork_occ : sc_sel_occs cls_occ = rdrNameOcc cname data_occ = mkClassDataConOcc cls_occ - dw_occ = mkWorkerOcc data_occ + dwrap_occ = mkDataConWrapperOcc data_occ + dwork_occ = mkDataConWorkerOcc data_occ tc_occ = mkClassTyConOcc cls_occ sc_sel_occs = [mkSuperDictSelOcc n cls_occ | n <- [1..length cxt]] @@ -340,19 +342,21 @@ getSysBinders mod (TyData {tcdName = tc_name, tcdCons = DataCons cons, tcdGeneric = Just want_generic, tcdLoc = loc}) -- The 'Just' is because this is an interface-file decl -- so it will say whether to derive generic stuff for it or not - = sequenceM ([new_sys_bndr mod n loc | n <- gen_occs] ++ - map con_sys_occ cons) + = mapM (new_sys_bndr mod loc) (gen_occs ++ concatMap mk_con_occs cons) where + new = new_sys_bndr -- c.f. TcTyDecls.tcTyDecl tc_occ = rdrNameOcc tc_name gen_occs | want_generic = [mkGenOcc1 tc_occ, mkGenOcc2 tc_occ] | otherwise = [] - con_sys_occ (ConDecl name _ _ _ loc) - = new_sys_bndr mod (mkWorkerOcc (rdrNameOcc name)) loc + mk_con_occs (ConDecl name _ _ _ _) + = [mkDataConWrapperOcc con_occ, mkDataConWorkerOcc con_occ] + where + con_occ = rdrNameOcc name -- The "source name" getSysBinders mod decl = returnM [] -new_sys_bndr mod occ loc = newTopBinder mod (mkRdrUnqual occ) loc +new_sys_bndr mod loc occ = newTopBinder mod (mkRdrUnqual occ) loc ----------------------------------------------------- diff --git a/ghc/compiler/rename/RnIfaces.lhs b/ghc/compiler/rename/RnIfaces.lhs index 309ab65..8a11006 100644 --- a/ghc/compiler/rename/RnIfaces.lhs +++ b/ghc/compiler/rename/RnIfaces.lhs @@ -31,7 +31,7 @@ import Id ( idType, idName, globalIdDetails ) import IdInfo ( GlobalIdDetails(..) ) import TcType ( tyClsNamesOfType, classNamesOfTheta ) import FieldLabel ( fieldLabelTyCon ) -import DataCon ( dataConTyCon ) +import DataCon ( dataConTyCon, dataConWrapId ) import TyCon ( visibleDataCons, isSynTyCon, getSynTyConDefn, tyConClass_maybe, tyConName ) import Class ( className, classSCTheta ) import Name ( Name {-instance NamedThing-}, isWiredInName, nameIsLocalOrFrom, @@ -189,13 +189,14 @@ rnIfaceDecl rn (mod, decl) = initRn (InterfaceMode mod) (rn decl) -- Tiresomely, we must get the "main" name for the -- thing, because that's what VSlurp contains, and what -- is recorded in the usage information -get_main_name (AClass cl) = className cl +get_main_name (AClass cl) = className cl +get_main_name (ADataCon dc) = tyConName (dataConTyCon dc) get_main_name (ATyCon tc) | Just clas <- tyConClass_maybe tc = get_main_name (AClass clas) | otherwise = tyConName tc get_main_name (AnId id) = case globalIdDetails id of - DataConId dc -> get_main_name (ATyCon (dataConTyCon dc)) + DataConWorkId dc -> get_main_name (ATyCon (dataConTyCon dc)) DataConWrapId dc -> get_main_name (ATyCon (dataConTyCon dc)) RecordSelId lbl -> get_main_name (ATyCon (fieldLabelTyCon lbl)) other -> idName id @@ -477,6 +478,7 @@ getWiredInGates (AClass cl) super_classes = classNamesOfTheta (classSCTheta cl) getWiredInGates (AnId the_id) = tyClsNamesOfType (idType the_id) +getWiredInGates (ADataCon dc) = tyClsNamesOfType (idType (dataConWrapId dc)) getWiredInGates (ATyCon tc) | isSynTyCon tc = tyClsNamesOfType ty | otherwise = unitFV (getName tc) diff --git a/ghc/compiler/rename/RnNames.lhs b/ghc/compiler/rename/RnNames.lhs index 74d183c..04fc4b4 100644 --- a/ghc/compiler/rename/RnNames.lhs +++ b/ghc/compiler/rename/RnNames.lhs @@ -32,7 +32,7 @@ import Module ( Module, ModuleName, ModuleEnv, moduleName, import Name ( Name, nameSrcLoc, nameOccName, nameModule, isExternalName ) import NameSet import NameEnv -import OccName ( OccName, dataName, isTcOcc ) +import OccName ( OccName, srcDataName, isTcOcc ) import HscTypes ( Provenance(..), ImportReason(..), GlobalRdrEnv, GenAvailInfo(..), AvailInfo, Avails, IsBootInterface, @@ -433,7 +433,7 @@ filterImports mod from (Just (want_hiding, import_items)) total_avails avails -> returnM [(a, []) | a <- avails] -- The 'explicits' list is irrelevant when hiding where - data_n = setRdrNameSpace n dataName + data_n = setRdrNameSpace n srcDataName get_item item = case check_item item of diff --git a/ghc/compiler/simplCore/OccurAnal.lhs b/ghc/compiler/simplCore/OccurAnal.lhs index 02fe904..fe035f3 100644 --- a/ghc/compiler/simplCore/OccurAnal.lhs +++ b/ghc/compiler/simplCore/OccurAnal.lhs @@ -20,7 +20,7 @@ module OccurAnal ( import CoreSyn import CoreFVs ( idRuleVars ) import CoreUtils ( exprIsTrivial ) -import Id ( isDataConId, isOneShotLambda, setOneShotLambda, +import Id ( isDataConWorkId, isOneShotLambda, setOneShotLambda, idOccInfo, setIdOccInfo, isExportedId, modifyIdInfo, idInfo, idArity, idSpecialisation, isLocalId, @@ -704,7 +704,7 @@ occAnalApp env (Var fun, args) is_rhs -- This is the *whole point* of the isRhsEnv predicate final_args_uds | isRhsEnv env, - isDataConId fun || valArgCount args < idArity fun + isDataConWorkId fun || valArgCount args < idArity fun = mapVarEnv markMany args_uds | otherwise = args_uds in diff --git a/ghc/compiler/simplCore/SimplUtils.lhs b/ghc/compiler/simplCore/SimplUtils.lhs index f6e4b66..31f6315 100644 --- a/ghc/compiler/simplCore/SimplUtils.lhs +++ b/ghc/compiler/simplCore/SimplUtils.lhs @@ -31,7 +31,7 @@ import CoreUtils ( cheapEqExpr, exprType, exprIsTrivial, findDefault, exprOkForSpeculation, exprIsValue ) import qualified Subst ( simplBndrs, simplBndr, simplLetId, simplLamBndr ) -import Id ( Id, idType, idInfo, isDataConId, +import Id ( Id, idType, idInfo, isDataConWorkId, mkSysLocal, isDeadBinder, idNewDemandInfo, idUnfolding, idNewStrictness ) @@ -275,7 +275,7 @@ interestingArg :: OutExpr -> Bool interestingArg (Var v) = hasSomeUnfolding (idUnfolding v) -- Was: isValueUnfolding (idUnfolding v') -- But that seems over-pessimistic - || isDataConId v + || isDataConWorkId v -- This accounts for an argument like -- () or [], which is definitely interesting interestingArg (Type _) = False diff --git a/ghc/compiler/simplCore/Simplify.lhs b/ghc/compiler/simplCore/Simplify.lhs index 588f71d..5ac4877 100644 --- a/ghc/compiler/simplCore/Simplify.lhs +++ b/ghc/compiler/simplCore/Simplify.lhs @@ -21,7 +21,7 @@ import SimplUtils ( mkCase, mkLam, newId, prepareAlts, ) import Var ( mustHaveLocalBinding ) import VarEnv -import Id ( Id, idType, idInfo, idArity, isDataConId, +import Id ( Id, idType, idInfo, idArity, isDataConWorkId, setIdUnfolding, isDeadBinder, idNewDemandInfo, setIdInfo, setIdOccInfo, zapLamIdInfo, setOneShotLambda, @@ -1131,8 +1131,8 @@ mkAtomicArgs :: Bool -- A strict binding -- if the strict-binding flag is on mkAtomicArgs is_strict ok_float_unlifted rhs - | (Var fun, args) <- collectArgs rhs, -- It's an application - isDataConId fun || valArgCount args < idArity fun -- And it's a constructor or PAP + | (Var fun, args) <- collectArgs rhs, -- It's an application + isDataConWorkId fun || valArgCount args < idArity fun -- And it's a constructor or PAP = go fun nilOL [] args -- Have a go | otherwise = bale_out -- Give up diff --git a/ghc/compiler/specialise/SpecConstr.lhs b/ghc/compiler/specialise/SpecConstr.lhs index ab7ccd4..603c2a6 100644 --- a/ghc/compiler/specialise/SpecConstr.lhs +++ b/ghc/compiler/specialise/SpecConstr.lhs @@ -19,7 +19,7 @@ import WwLib ( mkWorkerArgs ) import DataCon ( dataConRepArity ) import Type ( tyConAppArgs ) import Id ( Id, idName, idType, - isDataConId_maybe, + isDataConWorkId_maybe, mkUserLocal, mkSysLocal ) import Var ( Var ) import VarEnv @@ -582,7 +582,7 @@ is_con_app_maybe env (Lit lit) is_con_app_maybe env expr = case collectArgs expr of - (Var fun, args) | Just con <- isDataConId_maybe fun, + (Var fun, args) | Just con <- isDataConWorkId_maybe fun, args `lengthAtLeast` dataConRepArity con -- Might be > because the arity excludes type args -> Just (DataAlt con,args) diff --git a/ghc/compiler/stgSyn/CoreToStg.lhs b/ghc/compiler/stgSyn/CoreToStg.lhs index f6033c2..77b5918 100644 --- a/ghc/compiler/stgSyn/CoreToStg.lhs +++ b/ghc/compiler/stgSyn/CoreToStg.lhs @@ -28,7 +28,6 @@ import DataCon import CostCentre ( noCCS ) import VarSet import VarEnv -import DataCon ( dataConWrapId ) import Maybes ( maybeToBool ) import Name ( getOccName, isExternalName, isDllName ) import OccName ( occNameUserString ) @@ -497,12 +496,12 @@ coreToStgApp maybe_thunk_body f args res_ty = exprType (mkApps (Var f) args) app = case globalIdDetails f of - DataConId dc | saturated -> StgConApp dc args' - PrimOpId op -> ASSERT( saturated ) - StgOpApp (StgPrimOp op) args' res_ty - FCallId call -> ASSERT( saturated ) - StgOpApp (StgFCallOp call (idUnique f)) args' res_ty - _other -> StgApp f args' + DataConWorkId dc | saturated -> StgConApp dc args' + PrimOpId op -> ASSERT( saturated ) + StgOpApp (StgPrimOp op) args' res_ty + FCallId call -> ASSERT( saturated ) + StgOpApp (StgFCallOp call (idUnique f)) args' res_ty + _other -> StgApp f args' in returnLne ( @@ -1192,7 +1191,7 @@ rhsIsNonUpd p other_expr idAppIsNonUpd :: IdEnv HowBound -> Id -> Int -> [CoreExpr] -> Bool idAppIsNonUpd p id n_val_args args - | Just con <- isDataConId_maybe id = not (isCrossDllConApp con args) + | Just con <- isDataConWorkId_maybe id = not (isCrossDllConApp con args) | otherwise = False -- SDM: disbled. See comment with isPAP above. -- n_val_args < stgArity id (lookupBinding p id) diff --git a/ghc/compiler/stranal/DmdAnal.lhs b/ghc/compiler/stranal/DmdAnal.lhs index e02bf5e..b6bd92f 100644 --- a/ghc/compiler/stranal/DmdAnal.lhs +++ b/ghc/compiler/stranal/DmdAnal.lhs @@ -21,7 +21,7 @@ import CoreUtils ( exprIsValue, exprArity ) import DataCon ( dataConTyCon ) import TyCon ( isProductTyCon, isRecursiveTyCon ) import Id ( Id, idType, idInlinePragma, - isDataConId, isGlobalId, idArity, + isDataConWorkId, isGlobalId, idArity, #ifdef OLD_STRICTNESS idDemandInfo, idStrictness, idCprInfo, idName, #endif @@ -761,7 +761,7 @@ dmdTransform :: SigEnv -- The strictness environment dmdTransform sigs var dmd ------ DATA CONSTRUCTOR - | isDataConId var -- Data constructor + | isDataConWorkId var -- Data constructor = let StrictSig dmd_ty = idNewStrictness var -- It must have a strictness sig DmdType _ _ con_res = dmd_ty diff --git a/ghc/compiler/stranal/SaAbsInt.lhs b/ghc/compiler/stranal/SaAbsInt.lhs index 48bb957..3cd9ba4 100644 --- a/ghc/compiler/stranal/SaAbsInt.lhs +++ b/ghc/compiler/stranal/SaAbsInt.lhs @@ -23,7 +23,7 @@ module SaAbsInt ( import CmdLineOpts ( opt_AllStrict, opt_NumbersStrict ) import CoreSyn import CoreUnfold ( maybeUnfoldingTemplate ) -import Id ( Id, idType, idUnfolding, isDataConId_maybe, +import Id ( Id, idType, idUnfolding, isDataConWorkId_maybe, idStrictness, ) import DataCon ( dataConTyCon, splitProductType_maybe, dataConRepArgTys ) @@ -353,7 +353,7 @@ evalAbsence other val = anyBot val absId anal var env = case (lookupAbsValEnv env var, - isDataConId_maybe var, + isDataConWorkId_maybe var, idStrictness var, maybeUnfoldingTemplate (idUnfolding var)) of diff --git a/ghc/compiler/typecheck/TcClassDcl.lhs b/ghc/compiler/typecheck/TcClassDcl.lhs index fb29e56..639b772 100644 --- a/ghc/compiler/typecheck/TcClassDcl.lhs +++ b/ghc/compiler/typecheck/TcClassDcl.lhs @@ -29,6 +29,7 @@ import TcEnv ( TyThingDetails(..), tcLookupClass, tcExtendTyVarEnv2, tcExtendTyVarEnv ) +import TcTyDecls ( tcMkDataCon ) import TcBinds ( tcMonoBinds ) import TcMonoType ( TcSigInfo(..), tcHsType, tcHsTheta, mkTcSig ) import TcSimplify ( tcSimplifyCheck ) @@ -46,8 +47,7 @@ import Class ( classTyVars, classBigSig, classTyCon, Class, ClassOpItem, DefMeth (..) ) import TyCon ( tyConGenInfo ) import Subst ( substTyWith ) -import MkId ( mkDictSelId, mkDataConId, mkDataConWrapId, mkDefaultMethodId ) -import DataCon ( mkDataCon ) +import MkId ( mkDictSelId, mkDefaultMethodId ) import Id ( Id, idType, idName, mkUserLocal, setIdLocalExported, setInlinePragma ) import Name ( Name, NamedThing(..) ) import NameEnv ( NameEnv, lookupNameEnv, emptyNameEnv, unitNameEnv, plusNameEnv ) @@ -134,8 +134,8 @@ tcClassDecl1 (ClassDecl {tcdCtxt = context, tcdName = class_name, mappM (tcClassSig clas tyvars mb_dm_env) op_sigs `thenM` \ sig_stuff -> -- MAKE THE CLASS DETAILS - lookupSysName class_name mkClassDataConOcc `thenM` \ datacon_name -> - lookupSysName datacon_name mkWorkerOcc `thenM` \ datacon_wkr_name -> + lookupSysName class_name mkClassTyConOcc `thenM` \ tycon_name -> + lookupSysName class_name mkClassDataConOcc `thenM` \ datacon_name -> mapM (lookupSysName class_name . mkSuperDictSelOcc) [1..length context] `thenM` \ sc_sel_names -> -- We number off the superclass selectors, 1, 2, 3 etc so that we @@ -145,26 +145,20 @@ tcClassDecl1 (ClassDecl {tcdCtxt = context, tcdName = class_name, -- D_sc1, D_sc2 -- (We used to call them D_C, but now we can have two different -- superclasses both called C!) - lookupSysName class_name mkClassTyConOcc `thenM` \ tycon_name -> let (op_tys, op_items) = unzip sig_stuff sc_tys = mkPredTys sc_theta dict_component_tys = sc_tys ++ op_tys sc_sel_ids = [mkDictSelId sc_name clas | sc_name <- sc_sel_names] - - dict_con = mkDataCon datacon_name - [NotMarkedStrict | _ <- dict_component_tys] - [{- No labelled fields -}] - tyvars - [{-No context-}] - [{-No existential tyvars-}] [{-Or context-}] - dict_component_tys - (classTyCon clas) - dict_con_id dict_wrap_id - - dict_con_id = mkDataConId datacon_wkr_name dict_con - dict_wrap_id = mkDataConWrapId dict_con in + tcMkDataCon datacon_name + [{- No strictness -}] + [{- No labelled fields -}] + tyvars [{-No context-}] + [{-No existential tyvars-}] [{-Or context-}] + dict_component_tys + (classTyCon clas) `thenM` \ dict_con -> + returnM (class_name, ClassDetails sc_theta sc_sel_ids op_items dict_con tycon_name) \end{code} diff --git a/ghc/compiler/typecheck/TcEnv.lhs b/ghc/compiler/typecheck/TcEnv.lhs index edec045..0f1f088 100644 --- a/ghc/compiler/typecheck/TcEnv.lhs +++ b/ghc/compiler/typecheck/TcEnv.lhs @@ -62,7 +62,7 @@ import Var ( TyVar, Id, idType ) import VarSet import VarEnv import CoreSyn ( IdCoreRule ) -import DataCon ( DataCon ) +import DataCon ( DataCon, dataConWrapId ) import TyCon ( TyCon, DataConDetails ) import Class ( Class, ClassOpItem ) import Name ( Name, NamedThing(..), @@ -285,15 +285,21 @@ tcLookupGlobalId :: Name -> TcM Id tcLookupGlobalId name = tcLookupGlobal_maybe name `thenM` \ maybe_thing -> case maybe_thing of - Just (AnId id) -> returnM id - other -> notFound "tcLookupGlobal" name + Just (AnId id) -> returnM id + + -- When typechecking Haskell source, occurrences of + -- data constructors use the "source name", which maps + -- to ADataCon; we want the wrapper instead + Just (ADataCon dc) -> returnM (dataConWrapId dc) + + other -> notFound "tcLookupGlobal (id)" name tcLookupDataCon :: Name -> TcM DataCon tcLookupDataCon con_name - = tcLookupGlobalId con_name `thenM` \ con_id -> - case isDataConWrapId_maybe con_id of - Just data_con -> returnM data_con - Nothing -> failWithTc (badCon con_id) + = tcLookupGlobal_maybe con_name `thenM` \ maybe_thing -> + case maybe_thing of + Just (ADataCon data_con) -> returnM data_con + other -> notFound "tcLookupDataCon" con_name tcLookupClass :: Name -> TcM Class tcLookupClass name @@ -353,16 +359,19 @@ tcLookupId :: Name -> TcM Id tcLookupId name = tcLookup name `thenM` \ thing -> case thing of - ATcId tc_id lvl -> returnM tc_id - AGlobal (AnId id) -> returnM id - other -> pprPanic "tcLookupId" (ppr name) + ATcId tc_id lvl -> returnM tc_id + AGlobal (AnId id) -> returnM id + AGlobal (ADataCon dc) -> returnM (dataConWrapId dc) + -- C.f. tcLookupGlobalId + other -> pprPanic "tcLookupId" (ppr name) tcLookupIdLvl :: Name -> TcM (Id, Level) tcLookupIdLvl name = tcLookup name `thenM` \ thing -> case thing of - ATcId tc_id lvl -> returnM (tc_id, lvl) - AGlobal (AnId id) -> returnM (id, topIdLvl id) + ATcId tc_id lvl -> returnM (tc_id, lvl) + AGlobal (AnId id) -> returnM (id, topIdLvl id) + AGlobal (ADataCon dc) -> returnM (dataConWrapId dc, impLevel) other -> pprPanic "tcLookupIdLvl" (ppr name) tcLookupLocalIds :: [Name] -> TcM [TcId] diff --git a/ghc/compiler/typecheck/TcIfaceSig.lhs b/ghc/compiler/typecheck/TcIfaceSig.lhs index 0c3e896..fe27324 100644 --- a/ghc/compiler/typecheck/TcIfaceSig.lhs +++ b/ghc/compiler/typecheck/TcIfaceSig.lhs @@ -16,7 +16,8 @@ import TcHsSyn ( TypecheckedCoreBind ) import TcRnTypes import TcRnMonad import TcMonoType ( tcIfaceType, kcHsSigType ) -import TcEnv ( tcExtendTyVarEnv, tcExtendGlobalValEnv, tcLookupGlobalId ) +import TcEnv ( tcExtendTyVarEnv, tcExtendGlobalValEnv, tcLookupGlobalId, + tcLookupDataCon ) import RnHsSyn ( RenamedCoreDecl, RenamedTyClDecl ) import HsCore @@ -27,7 +28,7 @@ import CoreUnfold import CoreLint ( lintUnfolding ) import WorkWrap ( mkWrapper ) -import Id ( Id, mkVanillaGlobal, mkLocalId, isDataConWrapId_maybe ) +import Id ( Id, mkVanillaGlobal, mkLocalId, isDataConWorkId_maybe ) import MkId ( mkFCallId ) import IdInfo import TyCon ( tyConDataCons, tyConTyVars ) @@ -374,11 +375,10 @@ tcConAlt :: UfConAlt Name -> TcM DataCon tcConAlt (UfTupleAlt (HsTupCon boxity arity)) = returnM (tupleCon boxity arity) -tcConAlt (UfDataAlt con_name) - = tcVar con_name `thenM` \ con_id -> - returnM (case isDataConWrapId_maybe con_id of - Just con -> con - Nothing -> pprPanic "tcCoreAlt" (ppr con_id)) +tcConAlt (UfDataAlt con_name) -- When reading interface files + -- the con_name will be the real name of + -- the data con + = tcLookupDataCon con_name \end{code} %************************************************************************ diff --git a/ghc/compiler/typecheck/TcMType.lhs b/ghc/compiler/typecheck/TcMType.lhs index 097c7f9..9947d82 100644 --- a/ghc/compiler/typecheck/TcMType.lhs +++ b/ghc/compiler/typecheck/TcMType.lhs @@ -1016,7 +1016,7 @@ checkValidDataCon con -- This checks the argument types and -- ambiguity of the existential context (if any) addErrCtxt (existentialCtxt con) - (checkFreeness ex_tvs ex_theta) + (checkFreeness ex_tvs ex_theta) where ctxt = ConArgCtxt (dataConName con) (_, _, ex_tvs, ex_theta, _, _) = dataConSig con diff --git a/ghc/compiler/typecheck/TcMonoType.lhs b/ghc/compiler/typecheck/TcMonoType.lhs index e93f64d..33782b9 100644 --- a/ghc/compiler/typecheck/TcMonoType.lhs +++ b/ghc/compiler/typecheck/TcMonoType.lhs @@ -762,9 +762,10 @@ appKindCtxt pp = ptext SLIT("When checking kinds in") <+> quotes pp wrongThingErr expected thing name = pp_thing thing <+> quotes (ppr name) <+> ptext SLIT("used as a") <+> text expected where - pp_thing (AGlobal (ATyCon _)) = ptext SLIT("Type constructor") - pp_thing (AGlobal (AClass _)) = ptext SLIT("Class") - pp_thing (AGlobal (AnId _)) = ptext SLIT("Identifier") + pp_thing (AGlobal (ATyCon _)) = ptext SLIT("Type constructor") + pp_thing (AGlobal (AClass _)) = ptext SLIT("Class") + pp_thing (AGlobal (AnId _)) = ptext SLIT("Identifier") + pp_thing (AGlobal (ADataCon _)) = ptext SLIT("Data constructor") pp_thing (ATyVar _) = ptext SLIT("Type variable") pp_thing (ATcId _ _) = ptext SLIT("Local identifier") pp_thing (AThing _) = ptext SLIT("Utterly bogus") diff --git a/ghc/compiler/typecheck/TcRnDriver.lhs b/ghc/compiler/typecheck/TcRnDriver.lhs index 58d4038..d225b6c 100644 --- a/ghc/compiler/typecheck/TcRnDriver.lhs +++ b/ghc/compiler/typecheck/TcRnDriver.lhs @@ -830,8 +830,9 @@ tcTyClDecls tycl_decls -- an error we'd better stop now, to avoid a cascade traceTc (text "TyCl1") `thenM_` - tcTyAndClassDecls tycl_decls `thenM` \ tycl_things -> - tcExtendGlobalEnv tycl_things $ + tcTyAndClassDecls tycl_decls `thenM` \ tcg_env -> + -- Returns the extended environment + setGblEnv tcg_env $ traceTc (text "TyCl2") `thenM_` tcInterfaceSigs tycl_decls `thenM` \ tcg_env -> diff --git a/ghc/compiler/typecheck/TcTyClsDecls.lhs b/ghc/compiler/typecheck/TcTyClsDecls.lhs index 0da4daf..d978e3c 100644 --- a/ghc/compiler/typecheck/TcTyClsDecls.lhs +++ b/ghc/compiler/typecheck/TcTyClsDecls.lhs @@ -17,7 +17,7 @@ import HsSyn ( TyClDecl(..), ) import RnHsSyn ( RenamedTyClDecl, tyClDeclFVs ) import BasicTypes ( RecFlag(..), NewOrData(..) ) -import HscTypes ( implicitTyThingIds ) +import HscTypes ( implicitTyThings ) import TcRnMonad import TcEnv ( TcTyThing(..), TyThing(..), TyThingDetails(..), @@ -61,22 +61,19 @@ The main function ~~~~~~~~~~~~~~~~~ \begin{code} tcTyAndClassDecls :: [RenamedTyClDecl] - -> TcM [TyThing] -- Returns newly defined things: - -- types, classes and implicit Ids + -> TcM TcGblEnv -- Returns extended environment tcTyAndClassDecls decls = tcGroups (stronglyConnComp edges) where edges = map mkEdges (filter isTypeOrClassDecl decls) -tcGroups [] - = returnM [] +tcGroups [] = getGblEnv tcGroups (group:groups) - = tcGroup group `thenM` \ (env, new_things1) -> + = tcGroup group `thenM` \ env -> setGblEnv env $ - tcGroups groups `thenM` \ new_things2 -> - returnM (new_things1 ++ new_things2) + tcGroups groups \end{code} Dealing with a group @@ -124,8 +121,8 @@ The knot-tying parameters: @rec_details_list@ is an alist mapping @Name@s to \begin{code} tcGroup :: SCC RenamedTyClDecl - -> TcM (TcGblEnv, -- Input env extended by types and classes only - [TyThing]) -- Things defined by this group + -> TcM TcGblEnv -- Input env extended by types and classes + -- and their implicit Ids,DataCons tcGroup scc = -- Step 1 @@ -169,23 +166,20 @@ tcGroup scc ) `thenM` \ (_, env, tyclss) -> -- Step 7: Check validity + setGblEnv env $ + traceTc (text "ready for validity check") `thenM_` getModule `thenM` \ mod -> - setGblEnv env ( - mappM_ (checkValidTyCl mod) decls - ) `thenM_` + mappM_ (checkValidTyCl mod) decls `thenM_` traceTc (text "done") `thenM_` let -- Add the tycons that come from the classes -- We want them in the environment because -- they are mentioned in interface files - implicit_tycons, implicit_ids, all_tyclss :: [TyThing] - implicit_tycons = [ATyCon (classTyCon clas) | AClass clas <- tyclss] - all_tyclss = implicit_tycons ++ tyclss - implicit_ids = [AnId id | id <- implicitTyThingIds all_tyclss] - new_things = implicit_ids ++ all_tyclss + implicit_things = implicitTyThings tyclss in - returnM (env, new_things) + traceTc ((text "Adding" <+> ppr tyclss) $$ (text "and" <+> ppr implicit_things)) `thenM_` + tcExtendGlobalEnv implicit_things getGblEnv where decls = case scc of diff --git a/ghc/compiler/typecheck/TcTyDecls.lhs b/ghc/compiler/typecheck/TcTyDecls.lhs index 5ef86a3..8c1b9da 100644 --- a/ghc/compiler/typecheck/TcTyDecls.lhs +++ b/ghc/compiler/typecheck/TcTyDecls.lhs @@ -4,7 +4,7 @@ \section[TcTyDecls]{Typecheck type declarations} \begin{code} -module TcTyDecls ( tcTyDecl, kcConDetails ) where +module TcTyDecls ( tcTyDecl, kcConDetails, tcMkDataCon ) where #include "HsVersions.h" @@ -12,22 +12,23 @@ import HsSyn ( TyClDecl(..), ConDecl(..), HsConDetails(..), BangType, getBangType, getBangStrictness, conDetailsTys ) import RnHsSyn ( RenamedTyClDecl, RenamedConDecl, RenamedContext ) -import BasicTypes ( NewOrData(..) ) +import BasicTypes ( NewOrData(..), StrictnessMark ) import TcMonoType ( tcHsTyVars, tcHsTheta, tcHsType, kcHsContext, kcHsSigType, kcHsLiftedSigType ) import TcEnv ( tcExtendTyVarEnv, tcLookupTyCon, TyThingDetails(..) ) -import TcType ( tyVarsOfTypes, tyVarsOfPred, ThetaType ) +import TcType ( Type, tyVarsOfTypes, tyVarsOfPred, ThetaType ) import RnEnv ( lookupSysName ) import TcRnMonad import DataCon ( DataCon, mkDataCon, dataConFieldLabels ) -import FieldLabel ( fieldLabelName, fieldLabelType, allFieldLabelTags, mkFieldLabel ) -import MkId ( mkDataConId, mkDataConWrapId, mkRecordSelId ) +import FieldLabel ( FieldLabel, fieldLabelName, fieldLabelType, allFieldLabelTags, mkFieldLabel ) +import MkId ( mkDataConWorkId, mkDataConWrapId, mkRecordSelId ) import Var ( TyVar ) import Name ( Name ) -import OccName ( mkWorkerOcc, mkGenOcc1, mkGenOcc2 ) +import OccName ( mkDataConWrapperOcc, mkDataConWorkerOcc, + mkGenOcc1, mkGenOcc2, setOccNameSpace ) import Outputable import TyCon ( TyCon, DataConDetails(..), visibleDataCons, tyConTyVars, tyConName ) @@ -139,36 +140,55 @@ tcConDecls new_or_data tycon tyvars ctxt con_decls tc_datacon ex_tyvars ex_theta btys = mappM tcHsType (map getBangType btys) `thenM` \ arg_tys -> - mk_data_con ex_tyvars ex_theta (map getBangStrictness btys) arg_tys [] + tcMkDataCon name + (map getBangStrictness btys) + [{- No field labels -}] + tyvars ctxt ex_tyvars ex_theta + arg_tys tycon tc_rec_con ex_tyvars ex_theta fields - = checkTc (null ex_tyvars) (exRecConErr name) `thenM_` + = checkTc (null ex_tyvars) (exRecConErr name) `thenM_` mappM tc_field (fields `zip` allFieldLabelTags) `thenM` \ field_labels -> let - arg_stricts = [str | (n, bty) <- fields, - let str = getBangStrictness bty - ] + arg_stricts = [getBangStrictness bty | (n, bty) <- fields] + arg_tys = map fieldLabelType field_labels in - mk_data_con ex_tyvars ex_theta arg_stricts - (map fieldLabelType field_labels) field_labels + tcMkDataCon name arg_stricts field_labels + tyvars ctxt ex_tyvars ex_theta + arg_tys tycon tc_field ((field_label_name, bty), tag) = tcHsType (getBangType bty) `thenM` \ field_ty -> returnM (mkFieldLabel field_label_name tycon field_ty tag) - mk_data_con ex_tyvars ex_theta arg_stricts arg_tys fields - = lookupSysName name mkWorkerOcc `thenM` \ wkr_name -> - let - data_con = mkDataCon name arg_stricts fields - tyvars (thinContext arg_tys ctxt) - ex_tyvars ex_theta - arg_tys - tycon data_con_id data_con_wrap_id - - data_con_id = mkDataConId wkr_name data_con - data_con_wrap_id = mkDataConWrapId data_con - in - returnM data_con +tcMkDataCon :: Name + -> [StrictnessMark] -> [FieldLabel] + -> [TyVar] -> ThetaType + -> [TyVar] -> ThetaType + -> [Type] -> TyCon + -> TcM DataCon +-- A wrapper for DataCon.mkDataCon that +-- a) makes the worker Id +-- b) makes the wrapper Id if necessary, including +-- allocating its unique (hence monadic) +tcMkDataCon src_name arg_stricts fields + tyvars ctxt ex_tyvars ex_theta + arg_tys tycon + = lookupSysName src_name mkDataConWrapperOcc `thenM` \ wrap_name -> + lookupSysName src_name mkDataConWorkerOcc `thenM` \ work_name -> + -- This last one takes the name of the data constructor in the source + -- code, which (for Haskell source anyway) will be in the SrcDataName name + -- space, and makes it into a "real data constructor name" + let + data_con = mkDataCon src_name arg_stricts fields + tyvars (thinContext arg_tys ctxt) + ex_tyvars ex_theta + arg_tys tycon + data_con_work_id data_con_wrap_id + data_con_work_id = mkDataConWorkId work_name data_con + data_con_wrap_id = mkDataConWrapId wrap_name data_con + in + returnM data_con -- The context for a data constructor should be limited to -- the type variables mentioned in the arg_tys diff --git a/ghc/compiler/typecheck/TcType.lhs b/ghc/compiler/typecheck/TcType.lhs index 025f861..d604b07 100644 --- a/ghc/compiler/typecheck/TcType.lhs +++ b/ghc/compiler/typecheck/TcType.lhs @@ -16,6 +16,10 @@ is the principal client. \begin{code} module TcType ( -------------------------------- + -- TyThing + TyThing(..), -- instance NamedThing + + -------------------------------- -- Types TcType, TcSigmaType, TcRhoType, TcTauType, TcPredType, TcThetaType, TcTyVar, TcTyVarSet, TcKind, @@ -131,9 +135,10 @@ import Type ( -- Re-exports hasMoreBoxityInfo, liftedBoxity, superBoxity, typeKind, superKind, repType ) +import DataCon ( DataCon ) import TyCon ( TyCon, isUnLiftedTyCon ) import Class ( classHasFDs, Class ) -import Var ( TyVar, tyVarKind, isMutTyVar, mutTyVarDetails ) +import Var ( TyVar, Id, tyVarKind, isMutTyVar, mutTyVarDetails ) import ForeignCall ( Safety, playSafe ) import VarEnv import VarSet @@ -156,6 +161,26 @@ import Outputable %************************************************************************ %* * + TyThing +%* * +%************************************************************************ + +\begin{code} +data TyThing = AnId Id + | ADataCon DataCon + | ATyCon TyCon + | AClass Class + +instance NamedThing TyThing where + getName (AnId id) = getName id + getName (ATyCon tc) = getName tc + getName (AClass cl) = getName cl + getName (ADataCon dc) = getName dc +\end{code} + + +%************************************************************************ +%* * \subsection{Types} %* * %************************************************************************ diff --git a/ghc/compiler/types/PprType.lhs b/ghc/compiler/types/PprType.lhs index 0a931a1..fa96fdf 100644 --- a/ghc/compiler/types/PprType.lhs +++ b/ghc/compiler/types/PprType.lhs @@ -19,8 +19,8 @@ module PprType( -- friends: -- (PprType can see all the representations it's trying to print) import TypeRep ( Type(..), TyNote(..), Kind ) -- friend -import Type ( SourceType(..), TyThing(..) ) -import TcType ( ThetaType, PredType, +import Type ( SourceType(..) ) +import TcType ( ThetaType, PredType, TyThing(..), tcSplitSigmaTy, isPredTy, isDictTy, tcSplitTyConApp_maybe, tcSplitFunTy_maybe ) @@ -90,9 +90,10 @@ instance Outputable name => OutputableBndr (IPName name) where pprBndr _ n = ppr n -- Simple for now instance Outputable TyThing where - ppr (AnId id) = ptext SLIT("AnId") <+> ppr id - ppr (ATyCon tc) = ptext SLIT("ATyCon") <+> ppr tc - ppr (AClass cl) = ptext SLIT("AClass") <+> ppr cl + ppr (AnId id) = ptext SLIT("AnId") <+> ppr id + ppr (ATyCon tc) = ptext SLIT("ATyCon") <+> ppr tc + ppr (AClass cl) = ptext SLIT("AClass") <+> ppr cl + ppr (ADataCon dc) = ptext SLIT("ADataCon") <+> ppr dc \end{code} diff --git a/ghc/compiler/types/TyCon.lhs b/ghc/compiler/types/TyCon.lhs index 74658f2..349d096 100644 --- a/ghc/compiler/types/TyCon.lhs +++ b/ghc/compiler/types/TyCon.lhs @@ -67,7 +67,7 @@ import BasicTypes ( Arity, RecFlag(..), Boxity(..), import Name ( Name, nameUnique, NamedThing(getName) ) import PrelNames ( Unique, Uniquable(..), anyBoxConKey ) import PrimRep ( PrimRep(..), isFollowableRep ) -import Maybes ( expectJust ) +import Maybes ( expectJust, orElse ) import Outputable import FastString \end{code} @@ -363,27 +363,33 @@ setTyConName tc name = tc {tyConName = name, tyConUnique = nameUnique name} \end{code} \begin{code} +isFunTyCon :: TyCon -> Bool isFunTyCon (FunTyCon {}) = True isFunTyCon _ = False +isPrimTyCon :: TyCon -> Bool isPrimTyCon (PrimTyCon {}) = True isPrimTyCon _ = False +isUnLiftedTyCon :: TyCon -> Bool isUnLiftedTyCon (PrimTyCon {isUnLifted = is_unlifted}) = is_unlifted isUnLiftedTyCon (TupleTyCon {tyConBoxed = boxity}) = not (isBoxed boxity) isUnLiftedTyCon _ = False -- isBoxedTyCon should not be applied to SynTyCon, nor KindCon +isBoxedTyCon :: TyCon -> Bool isBoxedTyCon (AlgTyCon {}) = True isBoxedTyCon (FunTyCon {}) = True isBoxedTyCon (TupleTyCon {tyConBoxed = boxity}) = isBoxed boxity isBoxedTyCon (PrimTyCon {primTyConRep = rep}) = isFollowableRep rep -- isAlgTyCon returns True for both @data@ and @newtype@ +isAlgTyCon :: TyCon -> Bool isAlgTyCon (AlgTyCon {}) = True isAlgTyCon (TupleTyCon {}) = True isAlgTyCon other = False +isDataTyCon :: TyCon -> Bool -- isDataTyCon returns True for data types that are represented by -- heap-allocated constructors. -- These are srcutinised by Core-level @case@ expressions, and they @@ -391,7 +397,7 @@ isAlgTyCon other = False -- True for all @data@ types -- False for newtypes -- unboxed tuples -isDataTyCon (AlgTyCon {algTyConFlavour = new_or_data, algTyConRec = is_rec}) +isDataTyCon (AlgTyCon {algTyConFlavour = new_or_data}) = case new_or_data of NewTyCon _ -> False other -> True @@ -399,12 +405,11 @@ isDataTyCon (AlgTyCon {algTyConFlavour = new_or_data, algTyConRec = is_rec}) isDataTyCon (TupleTyCon {tyConBoxed = boxity}) = isBoxed boxity isDataTyCon other = False +isNewTyCon :: TyCon -> Bool isNewTyCon (AlgTyCon {algTyConFlavour = NewTyCon _}) = True isNewTyCon other = False -newTyConRep :: TyCon -> ([TyVar], Type) -newTyConRep (AlgTyCon {tyConTyVars = tvs, algTyConFlavour = NewTyCon rep}) = (tvs, rep) - +isProductTyCon :: TyCon -> Bool -- A "product" tycon -- has *one* constructor, -- is *not* existential @@ -416,29 +421,36 @@ isProductTyCon (AlgTyCon {dataCons = DataCons [data_con]}) = not (isExistentialD isProductTyCon (TupleTyCon {}) = True isProductTyCon other = False +isSynTyCon :: TyCon -> Bool isSynTyCon (SynTyCon {}) = True isSynTyCon _ = False +isEnumerationTyCon :: TyCon -> Bool isEnumerationTyCon (AlgTyCon {algTyConFlavour = EnumTyCon}) = True isEnumerationTyCon other = False +isTupleTyCon :: TyCon -> Bool -- The unit tycon didn't used to be classed as a tuple tycon -- but I thought that was silly so I've undone it -- If it can't be for some reason, it should be a AlgTyCon isTupleTyCon (TupleTyCon {}) = True isTupleTyCon other = False +isUnboxedTupleTyCon :: TyCon -> Bool isUnboxedTupleTyCon (TupleTyCon {tyConBoxed = boxity}) = not (isBoxed boxity) isUnboxedTupleTyCon other = False +isBoxedTupleTyCon :: TyCon -> Bool isBoxedTupleTyCon (TupleTyCon {tyConBoxed = boxity}) = isBoxed boxity isBoxedTupleTyCon other = False tupleTyConBoxity tc = tyConBoxed tc +isRecursiveTyCon :: TyCon -> Bool isRecursiveTyCon (AlgTyCon {algTyConRec = Recursive}) = True isRecursiveTyCon other = False +isForeignTyCon :: TyCon -> Bool -- isForeignTyCon identifies foreign-imported type constructors -- For the moment, they are primitive but lifted, but that may change isForeignTyCon (PrimTyCon {isUnLifted = is_unlifted}) = not is_unlifted @@ -452,7 +464,9 @@ tyConDataConDetails (TupleTyCon {dataCon = con}) = DataCons [con] tyConDataConDetails other = Unknown tyConDataCons :: TyCon -> [DataCon] -tyConDataCons tycon = expectJust "tyConDataCons" (tyConDataCons_maybe tycon) +-- It's convenient for tyConDataCons to return the +-- empty list for type synonyms etc +tyConDataCons tycon = tyConDataCons_maybe tycon `orElse` [] tyConDataCons_maybe :: TyCon -> Maybe [DataCon] tyConDataCons_maybe (AlgTyCon {dataCons = DataCons cons}) = Just cons @@ -473,6 +487,9 @@ tyConSelIds other_tycon = [] \end{code} \begin{code} +newTyConRep :: TyCon -> ([TyVar], Type) +newTyConRep (AlgTyCon {tyConTyVars = tvs, algTyConFlavour = NewTyCon rep}) = (tvs, rep) + tyConPrimRep :: TyCon -> PrimRep tyConPrimRep (PrimTyCon {primTyConRep = rep}) = rep tyConPrimRep tc = ASSERT( not (isUnboxedTupleTyCon tc) ) diff --git a/ghc/compiler/types/Type.lhs b/ghc/compiler/types/Type.lhs index ec41604..455c6cb 100644 --- a/ghc/compiler/types/Type.lhs +++ b/ghc/compiler/types/Type.lhs @@ -9,8 +9,6 @@ module Type ( Type, PredType, ThetaType, Kind, TyVarSubst, - TyThing(..), isTyClThing, - superKind, superBoxity, -- KX and BX respectively liftedBoxity, unliftedBoxity, -- :: BX openKindCon, -- :: KX @@ -110,29 +108,6 @@ import Maybe ( isJust ) %************************************************************************ %* * - TyThing -%* * -%************************************************************************ - -\begin{code} -data TyThing = AnId Id - | ATyCon TyCon - | AClass Class - -isTyClThing :: TyThing -> Bool -isTyClThing (ATyCon _) = True -isTyClThing (AClass _) = True -isTyClThing (AnId _) = False - -instance NamedThing TyThing where - getName (AnId id) = getName id - getName (ATyCon tc) = getName tc - getName (AClass cl) = getName cl -\end{code} - - -%************************************************************************ -%* * \subsection{Stuff to do with kinds.} %* * %************************************************************************ -- 1.7.10.4