diff options
| author | simonpj <unknown> | 2003-10-09 11:59:43 +0000 |
|---|---|---|
| committer | simonpj <unknown> | 2003-10-09 11:59:43 +0000 |
| commit | 98688c6e8fd33f31c51218cf93cbf03fe3a5e73d (patch) | |
| tree | 417682357fcd0733cd447f69e9b9032474348291 | |
| parent | 79c93a8a30aaaa6bd940c0677d6f3c57eb727fa2 (diff) | |
| download | haskell-98688c6e8fd33f31c51218cf93cbf03fe3a5e73d.tar.gz | |
[project @ 2003-10-09 11:58:39 by simonpj]
-------------------------
GHC heart/lung transplant
-------------------------
This major commit changes the way that GHC deals with importing
types and functions defined in other modules, during renaming and
typechecking. On the way I've changed or cleaned up numerous other
things, including many that I probably fail to mention here.
Major benefit: GHC should suck in many fewer interface files when
compiling (esp with -O). (You can see this with -ddump-rn-stats.)
It's also some 1500 lines of code shorter than before.
** So expect bugs! I can do a 3-stage bootstrap, and run
** the test suite, but you may be doing stuff I havn't tested.
** Don't update if you are relying on a working HEAD.
In particular, (a) External Core and (b) GHCi are very little tested.
But please, please DO test this version!
------------------------
Big things
------------------------
Interface files, version control, and importing declarations
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
* There is a totally new data type for stuff that lives in interface files:
Original names IfaceType.IfaceExtName
Types IfaceType.IfaceType
Declarations (type,class,id) IfaceSyn.IfaceDecl
Unfoldings IfaceSyn.IfaceExpr
(Previously we used HsSyn for type/class decls, and UfExpr for unfoldings.)
The new data types are in iface/IfaceType and iface/IfaceSyn. They are
all instances of Binary, so they can be written into interface files.
Previous engronkulation concering the binary instance of RdrName has
gone away -- RdrName is not an instance of Binary any more. Nor does
Binary.lhs need to know about the ``current module'' which it used to,
which made it specialised to GHC.
A good feature of this is that the type checker for source code doesn't
need to worry about the possibility that we might be typechecking interface
file stuff. Nor does it need to do renaming; we can typecheck direct from
IfaceSyn, saving a whole pass (module TcIface)
* Stuff from interface files is sucked in *lazily*, rather than being eagerly
sucked in by the renamer. Instead, we use unsafeInterleaveIO to capture
a thunk for the unfolding of an imported function (say). If that unfolding
is every pulled on, TcIface will scramble over the unfolding, which may
in turn pull in the interface files of things mentioned in the unfolding.
The External Package State is held in a mutable variable so that it
can be side-effected by this lazy-sucking-in process (which may happen
way later, e.g. when the simplifier runs). In effect, the EPS is a kind
of lazy memo table, filled in as we suck things in. Or you could think
of it as a global symbol table, populated on demand.
* This lazy sucking is very cool, but it can lead to truly awful bugs. The
intent is that updates to the symbol table happen atomically, but very bad
things happen if you read the variable for the table, and then force a
thunk which updates the table. Updates can get lost that way. I regret
this subtlety.
One example of the way it showed up is that the top level of TidyPgm
(which updates the global name cache) to be much more disciplined about
those updates, since TidyPgm may itself force thunks which allocate new
names.
* Version numbering in interface files has changed completely, fixing
one major bug with ghc --make. Previously, the version of A.f changed
only if A.f's type and unfolding was textually different. That missed
changes to things that A.f's unfolding mentions; which was fixed by
eagerly sucking in all of those things, and listing them in the module's
usage list. But that didn't work with --make, because they might have
been already sucked in.
Now, A.f's version changes if anything reachable from A.f (via interface
files) changes. A module with unchanged source code needs recompiling
only if the versions of any of its free variables changes. [This isn't
quite right for dictionary functions and rules, which aren't mentioned
explicitly in the source. There are extensive comments in module MkIface,
where all version-handling stuff is done.]
* We don't need equality on HsDecls any more (because they aren't used in
interface files). Instead we have a specialised equality for IfaceSyn
(eqIfDecl etc), which uses IfaceEq instead of Bool as its result type.
See notes in IfaceSyn.
* The horrid bit of the renamer that tried to predict what instance decls
would be needed has gone entirely. Instead, the type checker simply
sucks in whatever instance decls it needs, when it needs them. Easy!
Similarly, no need for 'implicitModuleFVs' and 'implicitTemplateHaskellFVs'
etc. Hooray!
Types and type checking
~~~~~~~~~~~~~~~~~~~~~~~
* Kind-checking of types is far far tidier (new module TcHsTypes replaces
the badly-named TcMonoType). Strangely, this was one of my
original goals, because the kind check for types is the Right Place to
do type splicing, but it just didn't fit there before.
* There's a new representation for newtypes in TypeRep.lhs. Previously
they were represented using "SourceTypes" which was a funny compromise.
Now they have their own constructor in the Type datatype. SourceType
has turned back into PredType, which is what it used to be.
* Instance decl overlap checking done lazily. Consider
instance C Int b
instance C a Int
These were rejected before as overlapping, because when seeking
(C Int Int) one couldn't tell which to use. But there's no problem when
seeking (C Bool Int); it can only be the second.
So instead of checking for overlap when adding a new instance declaration,
we check for overlap when looking up an Inst. If we find more than one
matching instance, we see if any of the candidates dominates the others
(in the sense of being a substitution instance of all the others);
and only if not do we report an error.
------------------------
Medium things
------------------------
* The TcRn monad is generalised a bit further. It's now based on utils/IOEnv.lhs,
the IO monad with an environment. The desugarer uses the monad too,
so that anything it needs can get faulted in nicely.
* Reduce the number of wired-in things; in particular Word and Integer
are no longer wired in. The latter required HsLit.HsInteger to get a
Type argument. The 'derivable type classes' data types (:+:, :*: etc)
are not wired in any more either (see stuff about derivable type classes
below).
* The PersistentComilerState is now held in a mutable variable
in the HscEnv. Previously (a) it was passed to and then returned by
many top-level functions, which was painful; (b) it was invariably
accompanied by the HscEnv. This change tidies up top-level plumbing
without changing anything important.
* Derivable type classes are treated much more like 'deriving' clauses.
Previously, the Ids for the to/from functions lived inside the TyCon,
but now the TyCon simply records their existence (with a simple boolean).
Anyone who wants to use them must look them up in the environment.
This in turn makes it easy to generate the to/from functions (done
in types/Generics) using HsSyn (like TcGenDeriv for ordinary derivings)
instead of CoreSyn, which in turn means that (a) we don't have to figure
out all the type arguments etc; and (b) it'll be type-checked for us.
Generally, the task of generating the code has become easier, which is
good for Manuel, who wants to make it more sophisticated.
* A Name now says what its "parent" is. For example, the parent of a data
constructor is its type constructor; the parent of a class op is its
class. This relationship corresponds exactly to the Avail data type;
there may be other places we can exploit it. (I made the change so that
version comparison in interface files would be a bit easier; but in
fact it tided up other things here and there (see calls to
Name.nameParent). For example, the declaration pool, of declararations
read from interface files, but not yet used, is now keyed only by the 'main'
name of the declaration, not the subordinate names.
* New types OccEnv and OccSet, with the usual operations.
OccNames can be efficiently compared, because they have uniques, thanks
to the hashing implementation of FastStrings.
* The GlobalRdrEnv is now keyed by OccName rather than RdrName. Not only
does this halve the size of the env (because we don't need both qualified
and unqualified versions in the env), but it's also more efficient because
we can use a UniqFM instead of a FiniteMap.
Consequential changes to Provenance, which has moved to RdrName.
* External Core remains a bit of a hack, as it was before, done with a mixture
of HsDecls (so that recursiveness and argument variance is still inferred),
and IfaceExprs (for value declarations). It's not thoroughly tested.
------------------------
Minor things
------------------------
* DataCon fields dcWorkId, dcWrapId combined into a single field
dcIds, that is explicit about whether the data con is a newtype or not.
MkId.mkDataConWorkId and mkDataConWrapId are similarly combined into
MkId.mkDataConIds
* Choosing the boxing strategy is done for *source* type decls only, and
hence is now in TcTyDecls, not DataCon.
* WiredIn names are distinguished by their n_sort field, not by their location,
which was rather strange
* Define Maybes.mapCatMaybes :: (a -> Maybe b) -> [a] -> [b]
and use it here and there
* Much better pretty-printing of interface files (--show-iface)
Many, many other small things.
------------------------
File changes
------------------------
* New iface/ subdirectory
* Much of RnEnv has moved to iface/IfaceEnv
* MkIface and BinIface have moved from main/ to iface/
* types/Variance has been absorbed into typecheck/TcTyDecls
* RnHiFiles and RnIfaces have vanished entirely. Their
work is done by iface/LoadIface
* hsSyn/HsCore has gone, replaced by iface/IfaceSyn
* typecheck/TcIfaceSig has gone, replaced by iface/TcIface
* typecheck/TcMonoType has been renamed to typecheck/TcHsType
* basicTypes/Var.hi-boot and basicTypes/Generics.hi-boot have gone altogether
149 files changed, 7731 insertions, 14535 deletions
diff --git a/ghc/compiler/Makefile b/ghc/compiler/Makefile index 04c8d8b618..c91154f10d 100644 --- a/ghc/compiler/Makefile +++ b/ghc/compiler/Makefile @@ -232,7 +232,7 @@ CLEAN_FILES += $(CONFIG_HS) ALL_DIRS = \ utils basicTypes types hsSyn prelude rename typecheck deSugar coreSyn \ specialise simplCore stranal stgSyn simplStg codeGen absCSyn main \ - profiling parser cprAnalysis compMan ndpFlatten cbits + profiling parser cprAnalysis compMan ndpFlatten cbits iface # Make sure we include Config.hs even if it doesn't exist yet... ALL_SRCS += $(CONFIG_HS) @@ -345,7 +345,9 @@ endif # The standard suffix rule for compiling a Haskell file # adds these flags to the command line -prelude/PrimOp_HC_OPTS = -no-recomp -H80m +# There used to be a -no-recomp flag on PrimOp, but why? +# It's an expensive module to recompile! +prelude/PrimOp_HC_OPTS = -H80m # because the NCG can't handle the 64-bit math in here prelude/PrelRules_HC_OPTS = -fvia-C diff --git a/ghc/compiler/absCSyn/AbsCUtils.lhs b/ghc/compiler/absCSyn/AbsCUtils.lhs index f842d195d7..24067c0a87 100644 --- a/ghc/compiler/absCSyn/AbsCUtils.lhs +++ b/ghc/compiler/absCSyn/AbsCUtils.lhs @@ -423,13 +423,6 @@ flatAbsC stmt@(CRetVector _ _ _ _) = returnFlt (AbsCNop, stmt) flatAbsC stmt@(CModuleInitBlock _ _ _) = returnFlt (AbsCNop, stmt) \end{code} -\begin{code} -flat_maybe :: Maybe AbstractC -> FlatM (Maybe AbstractC, AbstractC) -flat_maybe Nothing = returnFlt (Nothing, AbsCNop) -flat_maybe (Just abs_c) = flatAbsC abs_c `thenFlt` \ (heres, tops) -> - returnFlt (Just heres, tops) -\end{code} - %************************************************************************ %* * \subsection[flat-simultaneous]{Doing things simultaneously} @@ -606,6 +599,7 @@ mkHalfWord_HIADDR res arg let hw_shift = mkIntCLit (wORD_SIZE_IN_BITS `quot` 2) +# if WORDS_BIGENDIAN a_hw_mask1 = CMachOpStmt t_hw_mask1 MO_Nat_Shl [CLit (mkMachWord 1), hw_shift] Nothing @@ -613,12 +607,11 @@ mkHalfWord_HIADDR res arg = CMachOpStmt t_hw_mask2 MO_Nat_Sub [t_hw_mask1, CLit (mkMachWord 1)] Nothing final -# if WORDS_BIGENDIAN = CSequential [ a_hw_mask1, a_hw_mask2, CMachOpStmt res MO_Nat_And [arg, t_hw_mask2] Nothing ] # else - = CMachOpStmt res MO_Nat_Shr [arg, hw_shift] Nothing + final = CMachOpStmt res MO_Nat_Shr [arg, hw_shift] Nothing # endif in returnFlt final diff --git a/ghc/compiler/absCSyn/PprAbsC.lhs b/ghc/compiler/absCSyn/PprAbsC.lhs index bea6d67193..76b1f43f29 100644 --- a/ghc/compiler/absCSyn/PprAbsC.lhs +++ b/ghc/compiler/absCSyn/PprAbsC.lhs @@ -846,9 +846,7 @@ pprFCall call uniq args results vol_regs ] DNCall (DNCallSpec isStatic kind assem nm argTys resTy) -> let - target = StaticTarget (mkFastString nm) resultVar = "_ccall_result" - hasAssemArg = isStatic || kind == DNConstructor invokeOp = case kind of diff --git a/ghc/compiler/basicTypes/BasicTypes.lhs b/ghc/compiler/basicTypes/BasicTypes.lhs index de65b85984..cb08941c0c 100644 --- a/ghc/compiler/basicTypes/BasicTypes.lhs +++ b/ghc/compiler/basicTypes/BasicTypes.lhs @@ -17,10 +17,12 @@ module BasicTypes( Version, bumpVersion, initialVersion, bogusVersion, Arity, + + DeprecTxt, Unused, unused, - FixitySig(..), Fixity(..), FixityDirection(..), + Fixity(..), FixityDirection(..), defaultFixity, maxPrecedence, arrowFixity, negateFixity, negatePrecedence, compareFixity, @@ -29,11 +31,13 @@ module BasicTypes( NewOrData(..), - RecFlag(..), isRec, isNonRec, + RecFlag(..), isRec, isNonRec, boolToRecFlag, TopLevelFlag(..), isTopLevel, isNotTopLevel, - Boxity(..), isBoxed, tupleParens, + Boxity(..), isBoxed, + + TupCon(..), tupParens, tupleParens, OccInfo(..), seqOccInfo, isFragileOcc, isOneOcc, isDeadOcc, isLoopBreaker, @@ -53,8 +57,8 @@ module BasicTypes( #include "HsVersions.h" +import FastString( FastString ) import Outputable -import SrcLoc \end{code} %************************************************************************ @@ -96,15 +100,23 @@ type Version = Int bogusVersion :: Version -- Shouldn't look at these bogusVersion = error "bogusVersion" -bumpVersion :: Bool -> Version -> Version --- Bump if the predicate (typically equality between old and new) is false -bumpVersion False v = v+1 -bumpVersion True v = v +bumpVersion :: Version -> Version +bumpVersion v = v+1 initialVersion :: Version initialVersion = 1 \end{code} +%************************************************************************ +%* * + Deprecations +%* * +%************************************************************************ + + +\begin{code} +type DeprecTxt = FastString -- reason/explanation for deprecation +\end{code} %************************************************************************ %* * @@ -130,9 +142,13 @@ ipNameName (Linear n) = n mapIPName :: (a->b) -> IPName a -> IPName b mapIPName f (Dupable n) = Dupable (f n) mapIPName f (Linear n) = Linear (f n) + +instance Outputable name => Outputable (IPName name) where + ppr (Dupable n) = char '?' <> ppr n -- Ordinary implicit parameters + ppr (Linear n) = char '%' <> ppr n -- Splittable implicit parameters \end{code} - + %************************************************************************ %* * \subsection[Fixity]{Fixity info} @@ -141,15 +157,6 @@ mapIPName f (Linear n) = Linear (f n) \begin{code} ------------------------ -data FixitySig name = FixitySig name Fixity SrcLoc - -instance Eq name => Eq (FixitySig name) where - (FixitySig n1 f1 _) == (FixitySig n2 f2 _) = n1==n2 && f1==f2 - -instance Outputable name => Outputable (FixitySig name) where - ppr (FixitySig name fixity loc) = sep [ppr fixity, ppr name] - ------------------------- data Fixity = Fixity Int FixityDirection instance Outputable Fixity where @@ -219,6 +226,10 @@ data NewOrData = NewType -- "newtype Blah ..." | DataType -- "data Blah ..." deriving( Eq ) -- Needed because Demand derives Eq + +instance Outputable NewOrData where + ppr NewType = ptext SLIT("newtype") + ppr DataType = ptext SLIT("data") \end{code} @@ -240,8 +251,13 @@ isNotTopLevel TopLevel = False isTopLevel TopLevel = True isTopLevel NotTopLevel = False + +instance Outputable TopLevelFlag where + ppr TopLevel = ptext SLIT("<TopLevel>") + ppr NotTopLevel = ptext SLIT("<NotTopLevel>") \end{code} + %************************************************************************ %* * \subsection[Top-level/local]{Top-level/not-top level flag} @@ -257,10 +273,6 @@ data Boxity isBoxed :: Boxity -> Bool isBoxed Boxed = True isBoxed Unboxed = False - -tupleParens :: Boxity -> SDoc -> SDoc -tupleParens Boxed p = parens p -tupleParens Unboxed p = ptext SLIT("(#") <+> p <+> ptext SLIT("#)") \end{code} @@ -273,6 +285,7 @@ tupleParens Unboxed p = ptext SLIT("(#") <+> p <+> ptext SLIT("#)") \begin{code} data RecFlag = Recursive | NonRecursive + deriving( Eq ) isRec :: RecFlag -> Bool isRec Recursive = True @@ -281,6 +294,34 @@ isRec NonRecursive = False isNonRec :: RecFlag -> Bool isNonRec Recursive = False isNonRec NonRecursive = True + +boolToRecFlag :: Bool -> RecFlag +boolToRecFlag True = Recursive +boolToRecFlag False = NonRecursive + +instance Outputable RecFlag where + ppr Recursive = ptext SLIT("Recursive") + ppr NonRecursive = ptext SLIT("NonRecursive") +\end{code} + +%************************************************************************ +%* * + Tuples +%* * +%************************************************************************ + +\begin{code} +data TupCon = TupCon Boxity Arity + +instance Eq TupCon where + (TupCon b1 a1) == (TupCon b2 a2) = b1==b2 && a1==a2 + +tupParens :: TupCon -> SDoc -> SDoc +tupParens (TupCon b _) p = tupleParens b p + +tupleParens :: Boxity -> SDoc -> SDoc +tupleParens Boxed p = parens p +tupleParens Unboxed p = ptext SLIT("(#") <+> p <+> ptext SLIT("#)") \end{code} %************************************************************************ @@ -290,7 +331,7 @@ isNonRec NonRecursive = True %************************************************************************ This is the "Embedding-Projection pair" datatype, it contains -two pieces of code (normally either RenamedHsExpr's or Id's) +two pieces of code (normally either RenamedExpr's or Id's) If we have a such a pair (EP from to), the idea is that 'from' and 'to' represents functions of type @@ -400,12 +441,10 @@ The strictness annotations on types in data type declarations e.g. data T = MkT !Int !(Bool,Bool) \begin{code} -data StrictnessMark - = MarkedUserStrict -- "!" in a source decl - | MarkedUserUnboxed -- "!!" in a source decl - | MarkedStrict -- "!" in an interface decl: strict but not unboxed - | MarkedUnboxed -- "!!" in an interface decl: unboxed - | NotMarkedStrict -- No annotation at all +data StrictnessMark -- Used in interface decls only + = MarkedStrict + | MarkedUnboxed + | NotMarkedStrict deriving( Eq ) isMarkedUnboxed MarkedUnboxed = True @@ -415,10 +454,9 @@ isMarkedStrict NotMarkedStrict = False isMarkedStrict other = True -- All others are strict instance Outputable StrictnessMark where - ppr MarkedUserStrict = ptext SLIT("!u") ppr MarkedStrict = ptext SLIT("!") - ppr MarkedUnboxed = ptext SLIT("! !") - ppr NotMarkedStrict = empty + ppr MarkedUnboxed = ptext SLIT("!!") + ppr NotMarkedStrict = ptext SLIT("_") \end{code} diff --git a/ghc/compiler/basicTypes/DataCon.lhs b/ghc/compiler/basicTypes/DataCon.lhs index c2e51761d5..b9dcca2a62 100644 --- a/ghc/compiler/basicTypes/DataCon.lhs +++ b/ghc/compiler/basicTypes/DataCon.lhs @@ -5,16 +5,16 @@ \begin{code} module DataCon ( - DataCon, + DataCon, DataConIds(..), ConTag, fIRST_TAG, mkDataCon, dataConRepType, dataConSig, dataConName, dataConTag, dataConTyCon, dataConArgTys, dataConOrigArgTys, dataConInstOrigArgTys, dataConRepArgTys, dataConTheta, - dataConFieldLabels, dataConStrictMarks, + dataConFieldLabels, dataConStrictMarks, dataConExStricts, dataConSourceArity, dataConRepArity, dataConNumInstArgs, - dataConWorkId, dataConWrapId, dataConWrapId_maybe, + dataConWorkId, dataConWrapId, dataConWrapId_maybe, dataConImplicitIds, dataConRepStrictness, isNullaryDataCon, isTupleCon, isUnboxedTupleCon, isExistentialDataCon, classDataCon, dataConExistentialTyVars, @@ -29,11 +29,11 @@ import {-# SOURCE #-} PprType( pprType ) import Type ( Type, ThetaType, mkForAllTys, mkFunTys, mkTyConApp, - mkTyVarTys, splitTyConApp_maybe, repType, - mkPredTys, isStrictType + mkTyVarTys, splitTyConApp_maybe, + mkPredTys, isStrictPred ) import TyCon ( TyCon, tyConDataCons, tyConDataCons, isProductTyCon, - isTupleTyCon, isUnboxedTupleTyCon, isRecursiveTyCon ) + isTupleTyCon, isUnboxedTupleTyCon ) import Class ( Class, classTyCon ) import Name ( Name, NamedThing(..), nameUnique ) import Var ( TyVar, Id ) @@ -41,7 +41,6 @@ import FieldLabel ( FieldLabel ) import BasicTypes ( Arity, StrictnessMark(..) ) import Outputable import Unique ( Unique, Uniquable(..) ) -import Maybes ( orElse ) import ListSetOps ( assoc ) import Util ( zipEqual, zipWithEqual, notNull ) \end{code} @@ -217,7 +216,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 dcWrapId, because + -- longer in the type of the wrapper Id, because -- that makes it harder to use the wrap-id to rebuild -- values after record selection or in generics. @@ -228,41 +227,59 @@ data DataCon -- (before unboxing and flattening of -- strict fields) - dcRepArgTys :: [Type], -- Final, representation argument types, after unboxing and flattening, - -- and including existential dictionaries - - dcRepStrictness :: [StrictnessMark], -- One for each representation argument - - dcTyCon :: TyCon, -- Result tycon - -- Now the strictness annotations and field labels of the constructor dcStrictMarks :: [StrictnessMark], - -- Strictness annotations as deduced by the compiler. - -- Has no MarkedUserStrict; they have been changed to MarkedStrict - -- or MarkedUnboxed by the compiler. - -- *Includes the existential dictionaries* - -- length = length dcExTheta + dataConSourceArity dataCon + -- Strictness annotations as decided by the compiler. + -- Does *not* include the existential dictionaries + -- length = dataConSourceArity dataCon dcFields :: [FieldLabel], -- Field labels for this constructor, in the -- same order as the argument types; -- length = 0 (if not a record) or dataConSourceArity. + -- Constructor representation + dcRepArgTys :: [Type], -- Final, representation argument types, + -- after unboxing and flattening, + -- and *including* existential dictionaries + + dcRepStrictness :: [StrictnessMark], -- One for each representation argument + + dcTyCon :: TyCon, -- Result tycon + -- Finally, the curried worker function that corresponds to the constructor -- It doesn't have an unfolding; the code generator saturates these Ids -- and allocates a real constructor when it finds one. -- -- An entirely separate wrapper function is built in TcTyDecls - dcWorkId :: Id, -- The corresponding worker Id - -- Takes dcRepArgTys as its arguments - -- Perhaps this should be a 'Maybe'; not reqd for newtype constructors - - dcWrapId :: Maybe Id -- The wrapper Id, if it's necessary - -- It's deemed unnecessary if it performs the - -- identity function + dcIds :: DataConIds } +data DataConIds + = NewDC Id -- Newtypes have only a wrapper, but no worker + | AlgDC (Maybe Id) Id -- Algebraic data types always have a worker, and + -- may or may not have a wrapper, depending on whether + -- the wrapper does anything. + + -- *Neither* the worker *nor* the wrapper take the dcStupidTheta dicts as arguments + + -- The wrapper takes dcOrigArgTys as its arguments + -- The worker takes dcRepArgTys as its arguments + -- If the worker is absent, dcRepArgTys is the same as dcOrigArgTys + + -- The 'Nothing' case of AlgDC is important + -- 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.) + type ConTag = Int fIRST_TAG :: ConTag @@ -330,15 +347,15 @@ mkDataCon :: Name -> [TyVar] -> ThetaType -> [TyVar] -> ThetaType -> [Type] -> TyCon - -> Id -> Maybe Id -- Worker and possible wrapper + -> DataConIds -> DataCon -- Can get the tag from the TyCon mkDataCon name - arg_stricts -- Use [] to mean 'all non-strict' + arg_stricts -- Must match orig_arg_tys 1-1 fields tyvars theta ex_tyvars ex_theta orig_arg_tys tycon - work_id wrap_id + ids = con where con = MkData {dcName = name, @@ -347,9 +364,9 @@ mkDataCon name dcOrigArgTys = orig_arg_tys, dcRepArgTys = rep_arg_tys, dcExTyVars = ex_tyvars, dcExTheta = ex_theta, - dcStrictMarks = real_stricts, dcRepStrictness = rep_arg_stricts, + dcStrictMarks = arg_stricts, dcRepStrictness = rep_arg_stricts, dcFields = fields, dcTag = tag, dcTyCon = tycon, dcRepType = ty, - dcWorkId = work_id, dcWrapId = wrap_id} + dcIds = ids} -- Strictness marks for source-args -- *after unboxing choices*, @@ -359,11 +376,8 @@ mkDataCon name -- 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 ++ - zipWith (chooseBoxingStrategy tycon) - orig_arg_tys - (arg_stricts ++ repeat NotMarkedStrict) - real_arg_tys = ex_dict_tys ++ orig_arg_tys + real_arg_tys = ex_dict_tys ++ orig_arg_tys + real_stricts = map mk_dict_strict_mark ex_theta ++ arg_stricts -- Representation arguments and demands (rep_arg_stricts, rep_arg_tys) = computeRep real_stricts real_arg_tys @@ -375,8 +389,8 @@ mkDataCon name result_ty = mkTyConApp tycon (mkTyVarTys tyvars) -mk_dict_strict_mark ty | isStrictType ty = MarkedStrict - | otherwise = NotMarkedStrict +mk_dict_strict_mark pred | isStrictPred pred = MarkedStrict + | otherwise = NotMarkedStrict \end{code} \begin{code} @@ -393,16 +407,27 @@ dataConRepType :: DataCon -> Type dataConRepType = dcRepType dataConWorkId :: DataCon -> Id -dataConWorkId = dcWorkId +dataConWorkId dc = case dcIds dc of + AlgDC _ wrk_id -> wrk_id + NewDC _ -> pprPanic "dataConWorkId" (ppr dc) dataConWrapId_maybe :: DataCon -> Maybe Id -dataConWrapId_maybe = dcWrapId +dataConWrapId_maybe dc = case dcIds dc of + AlgDC mb_wrap _ -> mb_wrap + NewDC wrap -> Just wrap dataConWrapId :: DataCon -> Id -- 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 +dataConWrapId dc = case dcIds dc of + AlgDC (Just wrap) _ -> wrap + AlgDC Nothing wrk -> wrk -- worker=wrapper + NewDC wrap -> wrap + +dataConImplicitIds :: DataCon -> [Id] +dataConImplicitIds dc = case dcIds dc of + AlgDC (Just wrap) work -> [wrap,work] + AlgDC Nothing work -> [work] + NewDC wrap -> [wrap] dataConFieldLabels :: DataCon -> [FieldLabel] dataConFieldLabels = dcFields @@ -410,6 +435,11 @@ dataConFieldLabels = dcFields dataConStrictMarks :: DataCon -> [StrictnessMark] dataConStrictMarks = dcStrictMarks +dataConExStricts :: DataCon -> [StrictnessMark] +-- Strictness of *existential* arguments only +-- Usually empty, so we don't bother to cache this +dataConExStricts dc = map mk_dict_strict_mark (dcExTheta dc) + -- Number of type-instantiation arguments -- All the remaining arguments of the DataCon are (notionally) -- stored in the DataCon, and are matched in a case expression @@ -541,40 +571,8 @@ splitProductType str ty Just stuff -> stuff Nothing -> pprPanic (str ++ ": not a product") (pprType ty) --- We attempt to unbox/unpack a strict field when either: --- (i) The tycon is imported, and the field is marked '! !', or --- (ii) The tycon is defined in this module, the field is marked '!', --- and the -funbox-strict-fields flag is on. --- --- This ensures that if we compile some modules with -funbox-strict-fields and --- some without, the compiler doesn't get confused about the constructor --- representations. - -chooseBoxingStrategy :: TyCon -> Type -> StrictnessMark -> StrictnessMark - -- Transforms any MarkedUserStricts into MarkUnboxed or MarkedStrict -chooseBoxingStrategy tycon arg_ty strict - = case strict of - MarkedUserStrict -> MarkedStrict - MarkedUserUnboxed - | can_unbox -> MarkedUnboxed - | otherwise -> MarkedStrict - other -> strict - where - can_unbox = unbox arg_ty - -- beware: repType will go into a loop if we try this on a recursive - -- type (for reasons unknown...), hence the check for recursion below. - unbox ty = - case splitTyConApp_maybe ty of - Nothing -> False - Just (arg_tycon, _) - | isRecursiveTyCon arg_tycon -> False - | otherwise -> - case splitTyConApp_maybe (repType ty) of - Nothing -> False - Just (arg_tycon, _) -> isProductTyCon arg_tycon computeRep :: [StrictnessMark] -- Original arg strictness - -- [after strategy choice; can't be MarkedUserStrict] -> [Type] -- and types -> ([StrictnessMark], -- Representation arg strictness [Type]) -- And type @@ -586,5 +584,5 @@ computeRep stricts tys unbox MarkedStrict ty = [(MarkedStrict, ty)] unbox MarkedUnboxed ty = zipEqual "computeRep" (dataConRepStrictness arg_dc) arg_tys where - (_, _, arg_dc, arg_tys) = splitProductType "unbox_strict_arg_ty" (repType ty) + (_, _, arg_dc, arg_tys) = splitProductType "unbox_strict_arg_ty" ty \end{code} diff --git a/ghc/compiler/basicTypes/Id.lhs b/ghc/compiler/basicTypes/Id.lhs index b810376efa..3b36e58570 100644 --- a/ghc/compiler/basicTypes/Id.lhs +++ b/ghc/compiler/basicTypes/Id.lhs @@ -30,7 +30,6 @@ module Id ( isPrimOpId, isPrimOpId_maybe, isFCallId, isFCallId_maybe, isDataConWorkId, isDataConWorkId_maybe, - isDataConWrapId, isDataConWrapId_maybe, isBottomingId, hasNoBinding, @@ -90,8 +89,7 @@ import Var ( Id, DictId, globalIdDetails, setGlobalIdDetails ) import qualified Var ( mkLocalId, mkGlobalId, mkSpecPragmaId ) -import Type ( Type, typePrimRep, addFreeTyVars, - seqType, splitTyConApp_maybe ) +import Type ( Type, typePrimRep, addFreeTyVars, seqType) import IdInfo @@ -238,6 +236,7 @@ Meanwhile, it is not discarded as dead code. recordSelectorFieldLabel :: Id -> FieldLabel recordSelectorFieldLabel id = case globalIdDetails id of RecordSelId lbl -> lbl + other -> panic "recordSelectorFieldLabel" isRecordSelector id = case globalIdDetails id of RecordSelId lbl -> True @@ -267,14 +266,6 @@ isDataConWorkId_maybe id = case globalIdDetails id of DataConWorkId con -> Just con other -> Nothing -isDataConWrapId_maybe id = case globalIdDetails id of - DataConWrapId con -> Just con - other -> Nothing - -isDataConWrapId id = case globalIdDetails id of - DataConWrapId con -> True - other -> False - -- hasNoBinding returns True of an Id which may not have a -- binding, even though it is defined in this module. -- Data constructor workers used to be things of this kind, but @@ -297,7 +288,6 @@ isImplicitId id FCallId _ -> True PrimOpId _ -> True ClassOpId _ -> True - GenericOpId _ -> True DataConWorkId _ -> True DataConWrapId _ -> True -- These are are implied by their type or class decl; diff --git a/ghc/compiler/basicTypes/IdInfo.lhs b/ghc/compiler/basicTypes/IdInfo.lhs index a0002d7c85..0b5b79ad93 100644 --- a/ghc/compiler/basicTypes/IdInfo.lhs +++ b/ghc/compiler/basicTypes/IdInfo.lhs @@ -77,7 +77,6 @@ module IdInfo ( import CoreSyn -import TyCon ( TyCon ) import Class ( Class ) import PrimOp ( PrimOp ) import Var ( Id ) @@ -231,7 +230,6 @@ an IdInfo.hi-boot, but no Id.hi-boot, and GlobalIdDetails is imported data GlobalIdDetails = VanillaGlobal -- Imported from elsewhere, a default method Id. - | GenericOpId TyCon -- The to/from operations of a | RecordSelId FieldLabel -- The Id for a record selector | DataConWorkId DataCon -- The Id for a data constructor *worker* | DataConWrapId DataCon -- The Id for a data constructor *wrapper* @@ -252,7 +250,6 @@ notGlobalId = NotGlobalId instance Outputable GlobalIdDetails where ppr NotGlobalId = ptext SLIT("[***NotGlobalId***]") ppr VanillaGlobal = ptext SLIT("[GlobalId]") - ppr (GenericOpId _) = ptext SLIT("[GenericOp]") ppr (DataConWorkId _) = ptext SLIT("[DataCon]") ppr (DataConWrapId _) = ptext SLIT("[DataConWrapper]") ppr (ClassOpId _) = ptext SLIT("[ClassOp]") diff --git a/ghc/compiler/basicTypes/Literal.lhs b/ghc/compiler/basicTypes/Literal.lhs index edc77b7943..3781abefe9 100644 --- a/ghc/compiler/basicTypes/Literal.lhs +++ b/ghc/compiler/basicTypes/Literal.lhs @@ -30,16 +30,13 @@ import TysPrim ( charPrimTy, addrPrimTy, floatPrimTy, doublePrimTy, intPrimTy, wordPrimTy, int64PrimTy, word64PrimTy ) import PrimRep ( PrimRep(..) ) -import TcType ( Type, tcCmpType ) -import Type ( typePrimRep ) -import PprType ( pprParendType ) +import Type ( Type ) import CStrings ( pprFSInCStyle ) import Outputable import FastTypes import FastString import Binary -import Util ( thenCmp ) import Ratio ( numerator ) import FastString ( uniqueOfFS, lengthFS ) @@ -343,7 +340,7 @@ cmpLit (MachFloat a) (MachFloat b) = a `compare` b cmpLit (MachDouble a) (MachDouble b) = a `compare` b cmpLit (MachLabel a _) (MachLabel b _) = a `compare` b cmpLit lit1 lit2 | litTag lit1 <# litTag lit2 = LT - | otherwise = GT + | otherwise = GT litTag (MachChar _) = _ILIT(1) litTag (MachStr _) = _ILIT(2) diff --git a/ghc/compiler/basicTypes/MkId.hi-boot b/ghc/compiler/basicTypes/MkId.hi-boot index b4b0fe1a97..47b20fb9eb 100644 --- a/ghc/compiler/basicTypes/MkId.hi-boot +++ b/ghc/compiler/basicTypes/MkId.hi-boot @@ -1,5 +1,5 @@ _interface_ MkId 1 _exports_ -MkId mkDataConWorkId ; +MkId mkDataConIds ; _declarations_ -1 mkDataConWorkId _:_ Name.Name -> DataCon.DataCon -> Var.Id ;; +1 mkDataConIds _:_ Name.Name -> Name.Name -> DataCon.DataCon -> DataCon.DataConIds ;; diff --git a/ghc/compiler/basicTypes/MkId.hi-boot-5 b/ghc/compiler/basicTypes/MkId.hi-boot-5 index 95f2d9c53e..ff901a5840 100644 --- a/ghc/compiler/basicTypes/MkId.hi-boot-5 +++ b/ghc/compiler/basicTypes/MkId.hi-boot-5 @@ -1,4 +1,3 @@ __interface MkId 1 0 where -__export MkId mkDataConWorkId ; -1 mkDataConWorkId :: Name.Name -> DataCon.DataCon -> Var.Id ; - +__export MkId mkDataConIds ; +1 mkDataConIds :: Name.Name -> Name.Name -> DataCon.DataCon -> DataCon.DataConIds ; diff --git a/ghc/compiler/basicTypes/MkId.hi-boot-6 b/ghc/compiler/basicTypes/MkId.hi-boot-6 index 414a4ab100..d3f22527f3 100644 --- a/ghc/compiler/basicTypes/MkId.hi-boot-6 +++ b/ghc/compiler/basicTypes/MkId.hi-boot-6 @@ -1,4 +1,5 @@ module MkId where -mkDataConWorkId :: Name.Name -> DataCon.DataCon -> Var.Id +mkDataConIds :: Name.Name -> Name.Name -> DataCon.DataCon -> DataCon.DataConIds + diff --git a/ghc/compiler/basicTypes/MkId.lhs b/ghc/compiler/basicTypes/MkId.lhs index 1da519af6f..b629f373b4 100644 --- a/ghc/compiler/basicTypes/MkId.lhs +++ b/ghc/compiler/basicTypes/MkId.lhs @@ -16,7 +16,7 @@ module MkId ( mkDictFunId, mkDefaultMethodId, mkDictSelId, - mkDataConWorkId, mkDataConWrapId, + mkDataConIds, mkRecordSelId, mkPrimOpId, mkFCallId, @@ -30,7 +30,7 @@ module MkId ( mkRuntimeErrorApp, rEC_CON_ERROR_ID, iRREFUT_PAT_ERROR_ID, rUNTIME_ERROR_ID, nON_EXHAUSTIVE_GUARDS_ERROR_ID, nO_METHOD_BINDING_ERROR_ID, - pAT_ERROR_ID + pAT_ERROR_ID, eRROR_ID ) where #include "HsVersions.h" @@ -43,6 +43,7 @@ import TysPrim ( openAlphaTyVars, alphaTyVar, alphaTy, import TysWiredIn ( charTy, mkListTy ) import PrelRules ( primOpRules ) import Rules ( addRule ) +import Type ( TyThing(..) ) import TcType ( Type, ThetaType, mkDictTy, mkPredTys, mkTyConApp, mkTyVarTys, mkClassPred, tcEqPred, mkFunTys, mkFunTy, mkSigmaTy, tcSplitSigmaTy, @@ -57,35 +58,35 @@ import TyCon ( TyCon, isNewTyCon, tyConTyVars, tyConDataCons, import Class ( Class, classTyCon, classTyVars, classSelIds ) import Var ( Id, TyVar, Var ) import VarSet ( isEmptyVarSet ) -import Name ( mkFCallName, Name ) -import PrimOp ( PrimOp, primOpSig, mkPrimOpIdName ) +import Name ( mkFCallName, mkWiredInName, Name ) +import OccName ( mkOccFS, varName ) +import PrimOp ( PrimOp, primOpSig, primOpOcc, primOpTag ) import ForeignCall ( ForeignCall ) -import DataCon ( DataCon, - dataConFieldLabels, dataConRepArity, dataConTyCon, +import DataCon ( DataCon, DataConIds(..), + dataConFieldLabels, dataConRepArity, dataConArgTys, dataConRepType, - dataConOrigArgTys, - dataConTheta, - dataConSig, dataConStrictMarks, dataConWorkId, + dataConOrigArgTys, dataConTheta, + dataConSig, dataConStrictMarks, dataConExStricts, splitProductType ) import Id ( idType, mkGlobalId, mkVanillaGlobal, mkSysLocal, mkLocalId, mkTemplateLocals, mkTemplateLocalsNum, setIdLocalExported, - mkTemplateLocal, idNewStrictness, idName + mkTemplateLocal, idName ) import IdInfo ( IdInfo, noCafIdInfo, setUnfoldingInfo, setArityInfo, setSpecInfo, setCafInfo, setAllStrictnessInfo, vanillaIdInfo, GlobalIdDetails(..), CafInfo(..) ) -import NewDemand ( mkStrictSig, strictSigResInfo, DmdResult(..), +import NewDemand ( mkStrictSig, DmdResult(..), mkTopDmdType, topDmd, evalDmd, lazyDmd, retCPR, Demand(..), Demands(..) ) -import FieldLabel ( mkFieldLabel, fieldLabelName, - firstFieldLabelTag, allFieldLabelTags, fieldLabelType +import FieldLabel ( fieldLabelName, firstFieldLabelTag, + allFieldLabelTags, fieldLabelType ) import DmdAnal ( dmdAnalTopRhs ) import CoreSyn -import Unique ( mkBuiltinUnique ) +import Unique ( mkBuiltinUnique, mkPrimOpIdUnique ) import Maybes import PrelNames import Maybe ( isJust ) @@ -147,57 +148,6 @@ ghcPrimIds %* * %************************************************************************ -\begin{code} -mkDataConWorkId :: Name -> DataCon -> Id - -- Makes the *worker* for the data constructor; that is, the function - -- that takes the reprsentation arguments and builds the constructor. -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 - -- e.g. data T = MkT !(Int,Int) - -- Why? Because the *wrapper* is strict (and its unfolding has case - -- expresssions that do the evals) but the *worker* itself is not. - -- If we pretend it is strict then when we see - -- case x of y -> $wMkT y - -- the simplifier thinks that y is "sure to be evaluated" (because - -- $wMkT is strict) and drops the case. No, $wMkT is not strict. - -- - -- When the simplifer sees a pattern - -- case e of MkT x -> ... - -- it uses the dataConRepStrictness of MkT to mark x as evaluated; - -- but that's fine... dataConRepStrictness comes from the data con - -- not from the worker Id. - - tycon = dataConTyCon data_con - cpr_info | isProductTyCon tycon && - isDataTyCon tycon && - arity > 0 && - arity <= mAX_CPR_SIZE = retCPR - | otherwise = TopRes - -- RetCPR is only true for products that are real data types; - -- that is, not unboxed tuples or [non-recursive] newtypes - -mAX_CPR_SIZE :: Arity -mAX_CPR_SIZE = 10 --- We do not treat very big tuples as CPR-ish: --- a) for a start we get into trouble because there aren't --- "enough" unboxed tuple types (a tiresome restriction, --- but hard to fix), --- b) more importantly, big unboxed tuples get returned mainly --- on the stack, and are often then allocated in the heap --- by the caller. So doing CPR for them may in fact make --- things worse. -\end{code} - The wrapper for a constructor is an ordinary top-level binding that evaluates any strict args, unboxes any args that are going to be flattened, and calls the worker. @@ -235,45 +185,94 @@ Notice that Making an explicit case expression allows the simplifier to eliminate it in the (common) case where the constructor arg is already evaluated. + \begin{code} -mkDataConWrapId :: Name -> DataCon -> Maybe Id --- Only make a wrapper Id if necessary +mkDataConIds :: Name -> Name -> DataCon -> DataConIds + -- Makes the *worker* for the data constructor; that is, the function + -- that takes the reprsentation arguments and builds the constructor. +mkDataConIds wrap_name wkr_name data_con + | isNewTyCon tycon + = NewDC nt_wrap_id -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) + | any isMarkedStrict all_strict_marks -- Algebraic, needs wrapper + = AlgDC (Just alg_wrap_id) wrk_id - | 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.) + | otherwise -- Algebraic, no wrapper + = AlgDC Nothing wrk_id where (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 - 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 + ex_dict_tys = mkPredTys ex_theta + all_arg_tys = ex_dict_tys ++ orig_arg_tys + result_ty = mkTyConApp tycon (mkTyVarTys tyvars) - info | is_newtype = common_info `setUnfoldingInfo` newtype_unf - | otherwise = common_info `setUnfoldingInfo` data_unf - `setAllStrictnessInfo` Just wrap_sig + wrap_ty = mkForAllTys all_tyvars (mkFunTys all_arg_tys result_ty) + -- We used to include the stupid theta in the wrapper's args + -- but now we don't. Instead the type checker just injects these + -- extra constraints where necessary. - wrap_sig = mkStrictSig (mkTopDmdType arg_dmds res_info) - res_info = strictSigResInfo (idNewStrictness work_id) - arg_dmds = map mk_dmd strict_marks + ----------- Worker (algebraic data types only) -------------- + wrk_id = mkGlobalId (DataConWorkId data_con) wkr_name + (dataConRepType data_con) wkr_info + + wkr_arity = dataConRepArity data_con + wkr_info = noCafIdInfo + `setArityInfo` wkr_arity + `setAllStrictnessInfo` Just wkr_sig + + wkr_sig = mkStrictSig (mkTopDmdType (replicate wkr_arity topDmd) cpr_info) + -- Notice that we do *not* say the worker is strict + -- even if the data constructor is declared strict + -- e.g. data T = MkT !(Int,Int) + -- Why? Because the *wrapper* is strict (and its unfolding has case + -- expresssions that do the evals) but the *worker* itself is not. + -- If we pretend it is strict then when we see + -- case x of y -> $wMkT y + -- the simplifier thinks that y is "sure to be evaluated" (because + -- $wMkT is strict) and drops the case. No, $wMkT is not strict. + -- + -- When the simplifer sees a pattern + -- case e of MkT x -> ... + -- it uses the dataConRepStrictness of MkT to mark x as evaluated; + -- but that's fine... dataConRepStrictness comes from the data con + -- not from the worker Id. + + cpr_info | isProductTyCon tycon && + isDataTyCon tycon && + wkr_arity > 0 && + wkr_arity <= mAX_CPR_SIZE = retCPR + | otherwise = TopRes + -- RetCPR is only true for products that are real data types; + -- that is, not unboxed tuples or [non-recursive] newtypes + + ----------- Wrappers for newtypes -------------- + nt_wrap_id = mkGlobalId (DataConWrapId data_con) wrap_name wrap_ty nt_wrap_info + nt_wrap_info = noCafIdInfo -- The NoCaf-ness is set by noCafIdInfo + `setArityInfo` 1 -- Arity 1 + `setUnfoldingInfo` newtype_unf + newtype_unf = ASSERT( null ex_tyvars && null ex_theta && + 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) + + id_arg1 = mkTemplateLocal 1 (head orig_arg_tys) + + ----------- Wrappers for algebraic data types -------------- + alg_wrap_id = mkGlobalId (DataConWrapId data_con) wrap_name wrap_ty alg_wrap_info + alg_wrap_info = noCafIdInfo -- The NoCaf-ness is set by noCafIdInfo + `setArityInfo` alg_arity + -- It's important to specify the arity, so that partial + -- applications are treated as values + `setUnfoldingInfo` alg_unf + `setAllStrictnessInfo` Just wrap_sig + + all_strict_marks = dataConExStricts data_con ++ dataConStrictMarks data_con + wrap_sig = mkStrictSig (mkTopDmdType arg_dmds cpr_info) + arg_dmds = map mk_dmd all_strict_marks mk_dmd str | isMarkedStrict str = evalDmd | otherwise = lazyDmd -- The Cpr info can be important inside INLINE rhss, where the @@ -285,42 +284,19 @@ mkDataConWrapId wrap_name data_con -- ...(let w = C x in ...(w p q)...)... -- we want to see that w is strict in its two arguments - 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 - (zip (ex_dict_args++id_args) strict_marks) i3 [] - - con_app i rep_ids = mkApps (Var work_id) - (map varToCoreExpr (all_tyvars ++ reverse rep_ids)) - - ex_dict_tys = mkPredTys ex_theta - all_arg_tys = ex_dict_tys ++ orig_arg_tys - result_ty = mkTyConApp tycon (mkTyVarTys tyvars) + alg_unf = mkTopUnfolding $ Note InlineMe $ + mkLams all_tyvars $ + mkLams ex_dict_args $ mkLams id_args $ + foldr mk_case con_app + (zip (ex_dict_args ++ id_args) all_strict_marks) + i3 [] - wrap_ty = mkForAllTys all_tyvars (mkFunTys all_arg_tys result_ty) - -- We used to include the stupid theta in the wrapper's args - -- but now we don't. Instead the type checker just injects these - -- extra constraints where necessary. - - mkLocals i tys = (zipWith mkTemplateLocal [i..i+n-1] tys, i+n) - where - n = length tys + con_app i rep_ids = mkApps (Var wrk_id) + (map varToCoreExpr (all_tyvars ++ reverse rep_ids)) (ex_dict_args,i2) = mkLocals 1 ex_dict_tys (id_args,i3) = mkLocals i2 orig_arg_tys - arity = i3-1 - (id_arg1:_) = id_args -- Used for newtype only - - strict_marks = dataConStrictMarks data_con + alg_arity = i3-1 mk_case :: (Id, StrictnessMark) -- Arg, strictness @@ -343,6 +319,21 @@ mkDataConWrapId wrap_name data_con body i' (reverse con_args ++ rep_args))] where (con_args, i') = mkLocals i tys + +mAX_CPR_SIZE :: Arity +mAX_CPR_SIZE = 10 +-- We do not treat very big tuples as CPR-ish: +-- a) for a start we get into trouble because there aren't +-- "enough" unboxed tuple types (a tiresome restriction, +-- but hard to fix), +-- b) more importantly, big unboxed tuples get returned mainly +-- on the stack, and are often then allocated in the heap +-- by the caller. So doing CPR for them may in fact make +-- things worse. + +mkLocals i tys = (zipWith mkTemplateLocal [i..i+n-1] tys, i+n) + where + n = length tys \end{code} @@ -393,9 +384,6 @@ Similarly for (recursive) newtypes \begin{code} mkRecordSelId tycon field_label -- Assumes that all fields with the same field label have the same type - -- - -- Annoyingly, we have to pass in the unpackCString# Id, because - -- we can't conjure it up out of thin air = sel_id where sel_id = mkGlobalId (RecordSelId field_label) (fieldLabelName field_label) selector_ty info @@ -505,6 +493,7 @@ mkRecordSelId tycon field_label where arg_ids = mkTemplateLocalsNum field_base (dataConOrigArgTys data_con) -- No need to instantiate; same tyvars in datacon as tycon + -- Records can't be existential, so no existential tyvars or dicts unpack_base = field_base + length arg_ids uniqs = map mkBuiltinUnique [unpack_base..] @@ -548,7 +537,7 @@ mkReboxingAlt us con args rhs (DataAlt con, args', mkLets binds rhs) where - stricts = dataConStrictMarks con + stricts = dataConExStricts con ++ dataConStrictMarks con go [] stricts us = ([], []) @@ -613,10 +602,9 @@ mkDictSelId name clas -- But it's type must expose the representation of the dictionary -- to gat (say) C a -> (a -> a) - field_lbl = mkFieldLabel name tycon sel_ty tag - tag = assoc "MkId.mkDictSelId" (map idName (classSelIds clas) `zip` allFieldLabelTags) name + tag = assoc "MkId.mkDictSelId" (map idName (classSelIds clas) `zip` allFieldLabelTags) name - info = noCafIdInfo + info = noCafIdInfo `setArityInfo` 1 `setUnfoldingInfo` mkTopUnfolding rhs `setAllStrictnessInfo` Just strict_sig @@ -673,7 +661,9 @@ mkPrimOpId prim_op where (tyvars,arg_tys,res_ty, arity, strict_sig) = primOpSig prim_op ty = mkForAllTys tyvars (mkFunTys arg_tys res_ty) - name = mkPrimOpIdName prim_op + name = mkWiredInName gHC_PRIM (primOpOcc prim_op) + (mkPrimOpIdUnique (primOpTag prim_op)) + Nothing (AnId id) id = mkGlobalId (PrimOpId prim_op) name ty info info = noCafIdInfo @@ -817,6 +807,29 @@ they can unify with both unlifted and lifted types. Hence we provide another gun with which to shoot yourself in the foot. \begin{code} +mkWiredInIdName mod fs uniq id + = mkWiredInName mod (mkOccFS varName fs) uniq Nothing (AnId id) + +unsafeCoerceName = mkWiredInIdName gHC_PRIM FSLIT("unsafeCoerce#") unsafeCoerceIdKey unsafeCoerceId +nullAddrName = mkWiredInIdName gHC_PRIM FSLIT("nullAddr#") nullAddrIdKey nullAddrId +seqName = mkWiredInIdName gHC_PRIM FSLIT("seq") seqIdKey seqId +realWorldName = mkWiredInIdName gHC_PRIM FSLIT("realWorld#") realWorldPrimIdKey realWorldPrimId +lazyIdName = mkWiredInIdName pREL_BASE FSLIT("lazy") lazyIdKey lazyId + +errorName = mkWiredInIdName pREL_ERR FSLIT("error") errorIdKey eRROR_ID +recSelErrorName = mkWiredInIdName pREL_ERR FSLIT("recSelError") recSelErrorIdKey rEC_SEL_ERROR_ID +runtimeErrorName = mkWiredInIdName pREL_ERR FSLIT("runtimeError") runtimeErrorIdKey rUNTIME_ERROR_ID +irrefutPatErrorName = mkWiredInIdName pREL_ERR FSLIT("irrefutPatError") irrefutPatErrorIdKey iRREFUT_PAT_ERROR_ID +recConErrorName = mkWiredInIdName pREL_ERR FSLIT("recConError") recConErrorIdKey rEC_CON_ERROR_ID +patErrorName = mkWiredInIdName pREL_ERR FSLIT("patError") patErrorIdKey pAT_ERROR_ID +noMethodBindingErrorName = mkWiredInIdName pREL_ERR FSLIT("noMethodBindingError") + noMethodBindingErrorIdKey nO_METHOD_BINDING_ERROR_ID +nonExhaustiveGuardsErrorName + = mkWiredInIdName pREL_ERR FSLIT("nonExhaustiveGuardsError") + nonExhaustiveGuardsErrorIdKey nON_EXHAUSTIVE_GUARDS_ERROR_ID +\end{code} + +\begin{code} -- unsafeCoerce# :: forall a b. a -> b unsafeCoerceId = pcMiscPrelId unsafeCoerceName ty info @@ -930,9 +943,9 @@ rEC_SEL_ERROR_ID = mkRuntimeErrorId recSelErrorName rUNTIME_ERROR_ID = mkRuntimeErrorId runtimeErrorName iRREFUT_PAT_ERROR_ID = mkRuntimeErrorId irrefutPatErrorName rEC_CON_ERROR_ID = mkRuntimeErrorId recConErrorName -nON_EXHAUSTIVE_GUARDS_ERROR_ID = mkRuntimeErrorId nonExhaustiveGuardsErrorName pAT_ERROR_ID = mkRuntimeErrorId patErrorName nO_METHOD_BINDING_ERROR_ID = mkRuntimeErrorId noMethodBindingErrorName +nON_EXHAUSTIVE_GUARDS_ERROR_ID = mkRuntimeErrorId nonExhaustiveGuardsErrorName -- The runtime error Ids take a UTF8-encoded string as argument mkRuntimeErrorId name = pc_bottoming_Id name runtimeErrorTy diff --git a/ghc/compiler/basicTypes/Module.hi-boot-5 b/ghc/compiler/basicTypes/Module.hi-boot-5 index cdc5fbf581..ebde9b7076 100644 --- a/ghc/compiler/basicTypes/Module.hi-boot-5 +++ b/ghc/compiler/basicTypes/Module.hi-boot-5 @@ -1,4 +1,4 @@ __interface Module 1 0 where -__export Module Module ; -1 data Module ; +__export Module ModuleName ; +1 data ModuleName ; diff --git a/ghc/compiler/basicTypes/Module.hi-boot-6 b/ghc/compiler/basicTypes/Module.hi-boot-6 index 7677859749..d26545c44f 100644 --- a/ghc/compiler/basicTypes/Module.hi-boot-6 +++ b/ghc/compiler/basicTypes/Module.hi-boot-6 @@ -1,4 +1,4 @@ module Module where -data Module +data ModuleName diff --git a/ghc/compiler/basicTypes/Module.lhs b/ghc/compiler/basicTypes/Module.lhs index 4b59757c6a..ea4de1ed05 100644 --- a/ghc/compiler/basicTypes/Module.lhs +++ b/ghc/compiler/basicTypes/Module.lhs @@ -56,8 +56,8 @@ module Module , moduleString -- :: Module -> EncodedString , moduleUserString -- :: Module -> UserString + , mkModule , mkBasePkgModule -- :: UserString -> Module - , mkThPkgModule -- :: UserString -> Module , mkHomeModule -- :: ModuleName -> Module , isHomeModule -- :: Module -> Bool , mkPackageModule -- :: ModuleName -> Module @@ -83,9 +83,8 @@ module Module #include "HsVersions.h" import OccName import Outputable -import Packages ( PackageName, basePackage, thPackage ) +import Packages ( PackageName, basePackage ) import CmdLineOpts ( opt_InPackage ) -import FastString ( FastString ) import Unique ( Uniquable(..) ) import Maybes ( expectJust ) import UniqFM @@ -270,21 +269,16 @@ pprModule (Module mod p) = getPprStyle $ \ sty -> \begin{code} -mkBasePkgModule :: ModuleName -> Module -mkBasePkgModule mod_nm - = Module mod_nm pack_info +mkModule :: PackageName -> ModuleName -> Module +mkModule pkg_name mod_name + = Module mod_name pkg_info where - pack_info - | opt_InPackage == basePackage = ThisPackage - | otherwise = AnotherPackage + pkg_info + | opt_InPackage == pkg_name = ThisPackage + | otherwise = AnotherPackage -mkThPkgModule :: ModuleName -> Module -mkThPkgModule mod_nm - = Module mod_nm pack_info - where - pack_info - | opt_InPackage == thPackage = ThisPackage - | otherwise = AnotherPackage +mkBasePkgModule :: ModuleName -> Module +mkBasePkgModule mod_nm = mkModule basePackage mod_nm mkHomeModule :: ModuleName -> Module mkHomeModule mod_nm = Module mod_nm ThisPackage diff --git a/ghc/compiler/basicTypes/Name.lhs b/ghc/compiler/basicTypes/Name.lhs index acf518f9d3..3a68b58d1d 100644 --- a/ghc/compiler/basicTypes/Name.lhs +++ b/ghc/compiler/basicTypes/Name.lhs @@ -13,17 +13,18 @@ module Name ( mkInternalName, mkSystemName, mkSystemNameEncoded, mkSystemTvNameEncoded, mkFCallName, mkIPName, - mkExternalName, mkKnownKeyExternalName, mkWiredInName, + mkExternalName, mkWiredInName, nameUnique, setNameUnique, - nameOccName, nameModule, nameModule_maybe, - setNameOcc, setNameSrcLoc, - hashName, externaliseName, localiseName, + nameOccName, nameModule, nameModule_maybe, nameModuleName, + setNameOcc, + hashName, localiseName, - nameSrcLoc, eqNameByOcc, + nameSrcLoc, nameParent, nameParent_maybe, isSystemName, isInternalName, isExternalName, isTyVarName, isDllName, isWiredInName, + wiredInNameTyThing_maybe, nameIsLocalOrFrom, isHomePackageName, -- Class NamedThing and overloaded friends @@ -33,11 +34,14 @@ module Name ( #include "HsVersions.h" +import {-# SOURCE #-} TypeRep( TyThing ) + import OccName -- All of it -import Module ( Module, moduleName, isHomeModule ) +import Module ( Module, ModuleName, moduleName, isHomeModule ) import CmdLineOpts ( opt_Static ) -import SrcLoc ( noSrcLoc, isWiredInLoc, wiredInSrcLoc, SrcLoc ) +import SrcLoc ( noSrcLoc, wiredInSrcLoc, SrcLoc ) import Unique ( Unique, Uniquable(..), getKey, pprUnique ) +import Maybes ( orElse ) import FastTypes import Outputable \end{code} @@ -61,10 +65,13 @@ data Name = Name { -- the SrcLoc in a Name all that often. data NameSort - = External Module -- (a) TyCon, Class, their derived Ids, dfun Id - -- (b) Imported Id - -- (c) Top-level Id in the original source, even if - -- locally defined + = External Module (Maybe Name) + -- (Just parent) => this Name is a subordinate name of 'parent' + -- e.g. data constructor of a data type, method of a class + -- Nothing => not a subordinate + + | WiredIn Module (Maybe Name) TyThing + -- A variant of External, for wired-in things | Internal -- A user-defined Id or TyVar -- defined in the module being compiled @@ -100,6 +107,7 @@ Notes about the NameSorts: nameUnique :: Name -> Unique nameOccName :: Name -> OccName nameModule :: Name -> Module +nameModuleName :: Name -> ModuleName nameSrcLoc :: Name -> SrcLoc nameUnique name = n_uniq name @@ -115,24 +123,43 @@ isSystemName :: Name -> Bool isHomePackageName :: Name -> Bool isWiredInName :: Name -> Bool -isWiredInName name = isWiredInLoc (n_loc name) - -isExternalName (Name {n_sort = External _}) = True -isExternalName other = False +isWiredInName (Name {n_sort = WiredIn _ _ _}) = True +isWiredInName other = False -nameModule (Name { n_sort = External mod }) = mod -nameModule name = pprPanic "nameModule" (ppr name) +wiredInNameTyThing_maybe :: Name -> Maybe TyThing +wiredInNameTyThing_maybe (Name {n_sort = WiredIn _ _ thing}) = Just thing +wiredInNameTyThing_maybe other = Nothing -nameModule_maybe (Name { n_sort = External mod }) = Just mod -nameModule_maybe name = Nothing +isExternalName (Name {n_sort = External _ _}) = True +isExternalName (Name {n_sort = WiredIn _ _ _}) = True +isExternalName other = False isInternalName name = not (isExternalName name) -nameIsLocalOrFrom from (Name {n_sort = External mod}) = mod == from -nameIsLocalOrFrom from other = True +nameParent_maybe :: Name -> Maybe Name +nameParent_maybe (Name {n_sort = External _ p}) = p +nameParent_maybe (Name {n_sort = WiredIn _ p _}) = p +nameParent_maybe other = Nothing + +nameParent :: Name -> Name +nameParent name = case nameParent_maybe name of + Just parent -> parent + Nothing -> name + +nameModule name = nameModule_maybe name `orElse` pprPanic "nameModule" (ppr name) +nameModuleName name = moduleName (nameModule name) + +nameModule_maybe (Name { n_sort = External mod _}) = Just mod +nameModule_maybe (Name { n_sort = WiredIn mod _ _}) = Just mod +nameModule_maybe name = Nothing -isHomePackageName (Name {n_sort = External mod}) = isHomeModule mod -isHomePackageName other = True -- Internal and system names +nameIsLocalOrFrom from name + | isExternalName name = from == nameModule name + | otherwise = True + +isHomePackageName name + | isExternalName name = isHomeModule (nameModule name) + | otherwise = True -- Internal and system names isDllName :: Name -> Bool -- Does this name refer to something in a different DLL? isDllName nm = not opt_Static && not (isHomePackageName nm) @@ -142,18 +169,6 @@ isTyVarName name = isTvOcc (nameOccName name) isSystemName (Name {n_sort = System}) = True isSystemName other = False - -eqNameByOcc :: Name -> Name -> Bool --- Compare using the strings, not the unique --- See notes with HsCore.eq_ufVar -eqNameByOcc (Name {n_sort = sort1, n_occ = occ1}) - (Name {n_sort = sort2, n_occ = occ2}) - = sort1 `eq_sort` sort2 && occ1 == occ2 - where - eq_sort (External m1) (External m2) = moduleName m1 == moduleName m2 - eq_sort (External _) _ = False - eq_sort _ (External _) = False - eq_sort _ _ = True \end{code} @@ -175,16 +190,16 @@ mkInternalName uniq occ loc = Name { n_uniq = uniq, n_sort = Internal, n_occ = o -- * for interface files we tidyCore first, which puts the uniques -- into the print name (see setNameVisibility below) -mkExternalName :: Unique -> Module -> OccName -> SrcLoc -> Name -mkExternalName uniq mod occ loc = Name { n_uniq = uniq, n_sort = External mod, - n_occ = occ, n_loc = loc } - -mkKnownKeyExternalName :: Module -> OccName -> Unique -> Name -mkKnownKeyExternalName mod occ uniq - = mkExternalName uniq mod occ noSrcLoc +mkExternalName :: Unique -> Module -> OccName -> Maybe Name -> SrcLoc -> Name +mkExternalName uniq mod occ mb_parent loc + = Name { n_uniq = uniq, n_sort = External mod mb_parent, + n_occ = occ, n_loc = loc } -mkWiredInName :: Module -> OccName -> Unique -> Name -mkWiredInName mod occ uniq = mkExternalName uniq mod occ wiredInSrcLoc +mkWiredInName :: Module -> OccName -> Unique -> Maybe Name -> TyThing -> Name +mkWiredInName mod occ uniq mb_parent thing + = Name { n_uniq = uniq, + n_sort = WiredIn mod mb_parent thing, + n_occ = occ, n_loc = wiredInSrcLoc } mkSystemName :: Unique -> UserFS -> Name mkSystemName uniq fs = Name { n_uniq = uniq, n_sort = System, @@ -224,14 +239,8 @@ setNameUnique name uniq = name {n_uniq = uniq} setNameOcc :: Name -> OccName -> Name setNameOcc name occ = name {n_occ = occ} -externaliseName :: Name -> Module -> Name -externaliseName n mod = n { n_sort = External mod } - localiseName :: Name -> Name localiseName n = n { n_sort = Internal } - -setNameSrcLoc :: Name -> SrcLoc -> Name -setNameSrcLoc name loc = name {n_loc = loc} \end{code} @@ -294,19 +303,29 @@ instance OutputableBndr Name where pprName name@(Name {n_sort = sort, n_uniq = uniq, n_occ = occ}) = getPprStyle $ \ sty -> case sort of - External mod -> pprExternal sty name uniq mod occ - System -> pprSystem sty uniq occ - Internal -> pprInternal sty uniq occ + External mod mb_p -> pprExternal sty name uniq mod occ mb_p False + WiredIn mod mb_p thing -> pprExternal sty name uniq mod occ mb_p True + System -> pprSystem sty uniq occ + Internal -> pprInternal sty uniq occ -pprExternal sty name uniq mod occ +pprExternal sty name uniq mod occ mb_p is_wired | codeStyle sty = ppr (moduleName mod) <> char '_' <> pprOccName occ - | debugStyle sty = ppr (moduleName mod) <> dot <> ppr_debug_occ uniq occ + | debugStyle sty = sep [ppr (moduleName mod) <> dot <> pprOccName occ, + hsep [text "{-", + if is_wired then ptext SLIT("(w)") else empty, + pprUnique uniq, + case mb_p of + Nothing -> empty + Just n -> brackets (ppr n), + text "-}"]] | unqualStyle sty name = pprOccName occ | otherwise = ppr (moduleName mod) <> dot <> pprOccName occ pprInternal sty uniq occ | codeStyle sty = pprUnique uniq - | debugStyle sty = ppr_debug_occ uniq occ + | debugStyle sty = hsep [pprOccName occ, text "{-", + text (briefOccNameFlavour occ), + pprUnique uniq, text "-}"] | otherwise = pprOccName occ -- User style -- Like Internal, except that we only omit the unique in Iface style @@ -316,10 +335,6 @@ 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/NameSet.lhs b/ghc/compiler/basicTypes/NameSet.lhs index e75d3cd2cc..305e80d1ce 100644 --- a/ghc/compiler/basicTypes/NameSet.lhs +++ b/ghc/compiler/basicTypes/NameSet.lhs @@ -19,7 +19,7 @@ module NameSet ( -- Defs and uses Defs, Uses, DefUse, DefUses, emptyDUs, usesOnly, mkDUs, plusDU, - findUses, duDefs, duUses + findUses, duDefs, duUses, allUses ) where #include "HsVersions.h" @@ -120,9 +120,10 @@ delFVs ns s = delListFromNameSet s ns type Defs = NameSet type Uses = NameSet -type DefUse = (Maybe Defs, Uses) type DefUses = [DefUse] -- In dependency order: earlier Defs scope over later Uses + +type DefUse = (Maybe Defs, Uses) -- For items (Just ds, us), the use of any member -- of the ds implies that all the us are used too -- diff --git a/ghc/compiler/basicTypes/OccName.lhs b/ghc/compiler/basicTypes/OccName.lhs index 4ff4c87c6b..2a242a0e85 100644 --- a/ghc/compiler/basicTypes/OccName.lhs +++ b/ghc/compiler/basicTypes/OccName.lhs @@ -15,6 +15,17 @@ module OccName ( OccName, -- Abstract, instance of Outputable pprOccName, + -- The OccEnv type + OccEnv, emptyOccEnv, unitOccEnv, extendOccEnv, + lookupOccEnv, mkOccEnv, extendOccEnvList, elemOccEnv, + occEnvElts, foldOccEnv, plusOccEnv_C, extendOccEnv_C, + + + -- The OccSet type + OccSet, emptyOccSet, unitOccSet, mkOccSet, extendOccSet, extendOccSetList, + unionOccSets, unionManyOccSets, minusOccSet, elemOccSet, occSetElts, + foldOccSet, isEmptyOccSet, intersectOccSet, intersectsOccSet, + mkOccFS, mkSysOcc, mkSysOccFS, mkFCallOcc, mkKindOccFS, mkVarOcc, mkVarOccEncoded, mkSuperDictSelOcc, mkDFunOcc, mkForeignExportOcc, @@ -30,6 +41,8 @@ module OccName ( occNameFlavour, briefOccNameFlavour, setOccNameSpace, + mkTupleOcc, isTupleOcc_maybe, + -- Tidying up TidyOccEnv, emptyTidyOccEnv, tidyOccName, initTidyOccEnv, @@ -47,8 +60,10 @@ module OccName ( import Char ( isDigit, isUpper, isLower, isAlphaNum, ord, chr, digitToInt ) import Util ( thenCmp ) -import Unique ( Unique ) -import FiniteMap ( FiniteMap, emptyFM, lookupFM, addToFM, elemFM ) +import Unique ( Unique, mkUnique, Uniquable(..) ) +import BasicTypes ( Boxity(..), Arity ) +import UniqFM +import UniqSet import FastString import Outputable import Binary @@ -173,7 +188,11 @@ instance Outputable OccName where ppr = pprOccName pprOccName :: OccName -> SDoc -pprOccName (OccName sp occ) = pprEncodedFS occ +pprOccName (OccName sp occ) + = getPprStyle $ \ sty -> + pprEncodedFS occ <> if debugStyle sty then + braces (text (briefNameSpaceFlavour sp)) + else empty \end{code} @@ -227,6 +246,92 @@ mkVarOccEncoded fs = mkSysOccFS varName fs %************************************************************************ %* * + Environments +%* * +%************************************************************************ + +OccEnvs are used mainly for the envts in ModIfaces. + +They are efficient, because FastStrings have unique Int# keys. We assume +this key is less than 2^24, so we can make a Unique using + mkUnique ns key :: Unique +where 'ns' is a Char reprsenting the name space. This in turn makes it +easy to build an OccEnv. + +\begin{code} +instance Uniquable OccName where + getUnique (OccName ns fs) + = mkUnique char (I# (uniqueOfFS fs)) + where -- See notes above about this getUnique function + char = case ns of + VarName -> 'i' + DataName -> 'd' + TvName -> 'v' + TcClsName -> 't' + +type OccEnv a = UniqFM a + +emptyOccEnv :: OccEnv a +unitOccEnv :: OccName -> a -> OccEnv a +extendOccEnv :: OccEnv a -> OccName -> a -> OccEnv a +extendOccEnvList :: OccEnv a -> [(OccName, a)] -> OccEnv a +lookupOccEnv :: OccEnv a -> OccName -> Maybe a +mkOccEnv :: [(OccName,a)] -> OccEnv a +elemOccEnv :: OccName -> OccEnv a -> Bool +foldOccEnv :: (a -> b -> b) -> b -> OccEnv a -> b +occEnvElts :: OccEnv a -> [a] +extendOccEnv_C :: (a->a->a) -> OccEnv a -> OccName -> a -> OccEnv a +plusOccEnv_C :: (a->a->a) -> OccEnv a -> OccEnv a -> OccEnv a + +emptyOccEnv = emptyUFM +unitOccEnv = unitUFM +extendOccEnv = addToUFM +extendOccEnvList = addListToUFM +lookupOccEnv = lookupUFM +mkOccEnv = listToUFM +elemOccEnv = elemUFM +foldOccEnv = foldUFM +occEnvElts = eltsUFM +plusOccEnv_C = plusUFM_C +extendOccEnv_C = addToUFM_C + + +type OccSet = UniqFM OccName + +emptyOccSet :: OccSet +unitOccSet :: OccName -> OccSet +mkOccSet :: [OccName] -> OccSet +extendOccSet :: OccSet -> OccName -> OccSet +extendOccSetList :: OccSet -> [OccName] -> OccSet +unionOccSets :: OccSet -> OccSet -> OccSet +unionManyOccSets :: [OccSet] -> OccSet +minusOccSet :: OccSet -> OccSet -> OccSet +elemOccSet :: OccName -> OccSet -> Bool +occSetElts :: OccSet -> [OccName] +foldOccSet :: (OccName -> b -> b) -> b -> OccSet -> b +isEmptyOccSet :: OccSet -> Bool +intersectOccSet :: OccSet -> OccSet -> OccSet +intersectsOccSet :: OccSet -> OccSet -> Bool + +emptyOccSet = emptyUniqSet +unitOccSet = unitUniqSet +mkOccSet = mkUniqSet +extendOccSet = addOneToUniqSet +extendOccSetList = addListToUniqSet +unionOccSets = unionUniqSets +unionManyOccSets = unionManyUniqSets +minusOccSet = minusUniqSet +elemOccSet = elementOfUniqSet +occSetElts = uniqSetToList +foldOccSet = foldUniqSet +isEmptyOccSet = isEmptyUniqSet +intersectOccSet = intersectUniqSets +intersectsOccSet s1 s2 = not (isEmptyOccSet (s1 `intersectOccSet` s2)) +\end{code} + + +%************************************************************************ +%* * \subsection{Predicates and taking them apart} %* * %************************************************************************ @@ -256,10 +361,12 @@ 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" +briefOccNameFlavour (OccName sp _) = briefNameSpaceFlavour sp + +briefNameSpaceFlavour DataName = "d" +briefNameSpaceFlavour VarName = "v" +briefNameSpaceFlavour TvName = "tv" +briefNameSpaceFlavour TcClsName = "tc" \end{code} \begin{code} @@ -289,6 +396,7 @@ isDataOcc other = False -- Pretty inefficient! isSymOcc (OccName DataName s) = isLexConSym (decodeFS s) isSymOcc (OccName VarName s) = isLexSym (decodeFS s) +isSymOcc other = False \end{code} @@ -448,31 +556,25 @@ because that isn't a single lexeme. So we encode it to 'lle' and *then* tack on the '1', if necessary. \begin{code} -type TidyOccEnv = FiniteMap FastString Int -- The in-scope OccNames -emptyTidyOccEnv = emptyFM +type TidyOccEnv = OccEnv Int -- The in-scope OccNames + -- Range gives a plausible starting point for new guesses + +emptyTidyOccEnv = emptyOccEnv initTidyOccEnv :: [OccName] -> TidyOccEnv -- Initialise with names to avoid! -initTidyOccEnv = foldl (\env (OccName _ fs) -> addToFM env fs 1) emptyTidyOccEnv +initTidyOccEnv = foldl (\env occ -> extendOccEnv env occ 1) emptyTidyOccEnv tidyOccName :: TidyOccEnv -> OccName -> (TidyOccEnv, OccName) tidyOccName in_scope occ@(OccName occ_sp fs) - | not (fs `elemFM` in_scope) - = (addToFM in_scope fs 1, occ) -- First occurrence - - | otherwise -- Already occurs - = go in_scope (unpackFS fs) - where - - go in_scope str = case lookupFM in_scope pk_str of - Just n -> go (addToFM in_scope pk_str (n+1)) (str ++ show n) - -- Need to go round again, just in case "t3" (say) - -- clashes with a "t3" that's already in scope - - Nothing -> (addToFM in_scope pk_str 1, mkSysOccFS occ_sp pk_str) - -- str is now unique - where - pk_str = mkFastString str + = case lookupOccEnv in_scope occ of + Nothing -> -- Not already used: make it used + (extendOccEnv in_scope occ 1, occ) + + Just n -> -- Already used: make a new guess, + -- change the guess base, and try again + tidyOccName (extendOccEnv in_scope occ (n+1)) + (mkSysOcc occ_sp (unpackFS fs ++ show n)) \end{code} @@ -544,20 +646,6 @@ encode cs = case maybe_tuple cs of go [] = [] go (c:cs) = encode_ch c ++ go cs -maybe_tuple "(# #)" = Just("Z1H") -maybe_tuple ('(' : '#' : cs) = case count_commas (0::Int) cs of - (n, '#' : ')' : cs) -> Just ('Z' : shows (n+1) "H") - other -> Nothing -maybe_tuple "()" = Just("Z0T") -maybe_tuple ('(' : cs) = case count_commas (0::Int) cs of - (n, ')' : cs) -> Just ('Z' : shows (n+1) "T") - other -> Nothing -maybe_tuple other = Nothing - -count_commas :: Int -> String -> (Int, String) -count_commas n (',' : cs) = count_commas (n+1) cs -count_commas n cs = (n,cs) - encodeFS :: UserFS -> EncodedFS encodeFS fast_str | all unencodedChar str = fast_str | otherwise = mkFastString (encode str) @@ -613,56 +701,120 @@ decodeFS fs = mkFastString (decode (unpackFS fs)) decode :: EncodedString -> UserString decode [] = [] -decode ('Z' : rest) = decode_escape rest -decode ('z' : rest) = decode_escape rest +decode ('Z' : d : rest) | isDigit d = decode_tuple d rest + | otherwise = decode_upper d : decode rest +decode ('z' : d : rest) | isDigit d = decode_num_esc d rest + | otherwise = decode_lower d : decode rest decode (c : rest) = c : decode rest -decode_escape :: EncodedString -> UserString - -decode_escape ('L' : rest) = '(' : decode rest -decode_escape ('R' : rest) = ')' : decode rest -decode_escape ('M' : rest) = '[' : decode rest -decode_escape ('N' : rest) = ']' : decode rest -decode_escape ('C' : rest) = ':' : decode rest -decode_escape ('Z' : rest) = 'Z' : decode rest - -decode_escape ('z' : rest) = 'z' : decode rest -decode_escape ('a' : rest) = '&' : decode rest -decode_escape ('b' : rest) = '|' : decode rest -decode_escape ('c' : rest) = '^' : decode rest -decode_escape ('d' : rest) = '$' : decode rest -decode_escape ('e' : rest) = '=' : decode rest -decode_escape ('g' : rest) = '>' : decode rest -decode_escape ('h' : rest) = '#' : decode rest -decode_escape ('i' : rest) = '.' : decode rest -decode_escape ('l' : rest) = '<' : decode rest -decode_escape ('m' : rest) = '-' : decode rest -decode_escape ('n' : rest) = '!' : decode rest -decode_escape ('p' : rest) = '+' : decode rest -decode_escape ('q' : rest) = '\'' : decode rest -decode_escape ('r' : rest) = '\\' : decode rest -decode_escape ('s' : rest) = '/' : decode rest -decode_escape ('t' : rest) = '*' : decode rest -decode_escape ('u' : rest) = '_' : decode rest -decode_escape ('v' : rest) = '%' : decode rest - --- Tuples are coded as Z23T +decode_upper, decode_lower :: Char -> Char + +decode_upper 'L' = '(' +decode_upper 'R' = ')' +decode_upper 'M' = '[' +decode_upper 'N' = ']' +decode_upper 'C' = ':' +decode_upper 'Z' = 'Z' +decode_upper ch = pprTrace "decode_upper" (char ch) ch + +decode_lower 'z' = 'z' +decode_lower 'a' = '&' +decode_lower 'b' = '|' +decode_lower 'c' = '^' +decode_lower 'd' = '$' +decode_lower 'e' = '=' +decode_lower 'g' = '>' +decode_lower 'h' = '#' +decode_lower 'i' = '.' +decode_lower 'l' = '<' +decode_lower 'm' = '-' +decode_lower 'n' = '!' +decode_lower 'p' = '+' +decode_lower 'q' = '\'' +decode_lower 'r' = '\\' +decode_lower 's' = '/' +decode_lower 't' = '*' +decode_lower 'u' = '_' +decode_lower 'v' = '%' +decode_lower ch = pprTrace "decode_lower" (char ch) ch + -- Characters not having a specific code are coded as z224U -decode_escape (c : rest) - | isDigit c = go (digitToInt c) rest +decode_num_esc d rest + = go (digitToInt d) rest where go n (c : rest) | isDigit c = go (10*n + digitToInt c) rest - go 0 ('T' : rest) = "()" ++ (decode rest) - go n ('T' : rest) = '(' : replicate (n-1) ',' ++ ')' : decode rest - go 1 ('H' : rest) = "(# #)" ++ (decode rest) - go n ('H' : rest) = '(' : '#' : replicate (n-1) ',' ++ '#' : ')' : decode rest go n ('U' : rest) = chr n : decode rest - go n other = pprPanic "decode_escape" (ppr n <+> text (c:rest)) + go n other = pprPanic "decode_num_esc" (ppr n <+> text other) +\end{code} + -decode_escape (c : rest) = pprTrace "decode_escape" (char c) (decode rest) -decode_escape [] = pprTrace "decode_escape" (text "empty") "" +%************************************************************************ +%* * + Stuff for dealing with tuples +%* * +%************************************************************************ + +Tuples are encoded as + Z3T or Z3H +for 3-tuples or unboxed 3-tuples respectively. No other encoding starts + Z<digit> + +* "(# #)" is the tycon for an unboxed 1-tuple (not 0-tuple) + There are no unboxed 0-tuples. + +* "()" is the tycon for a boxed 0-tuple. + There are no boxed 1-tuples. + + +\begin{code} +maybe_tuple :: UserString -> Maybe EncodedString + +maybe_tuple "(# #)" = Just("Z1H") +maybe_tuple ('(' : '#' : cs) = case count_commas (0::Int) cs of + (n, '#' : ')' : cs) -> Just ('Z' : shows (n+1) "H") + other -> Nothing +maybe_tuple "()" = Just("Z0T") +maybe_tuple ('(' : cs) = case count_commas (0::Int) cs of + (n, ')' : cs) -> Just ('Z' : shows (n+1) "T") + other -> Nothing +maybe_tuple other = Nothing + +count_commas :: Int -> String -> (Int, String) +count_commas n (',' : cs) = count_commas (n+1) cs +count_commas n cs = (n,cs) \end{code} +\begin{code} +decode_tuple :: Char -> EncodedString -> UserString +decode_tuple d rest + = go (digitToInt d) rest + where + go n (c : rest) | isDigit c = go (10*n + digitToInt c) rest + go 0 ['T'] = "()" + go n ['T'] = '(' : replicate (n-1) ',' ++ ")" + go 1 ['H'] = "(# #)" + go n ['H'] = '(' : '#' : replicate (n-1) ',' ++ "#)" + go n other = pprPanic "decode_tuple" (ppr n <+> text other) + +mkTupleOcc :: NameSpace -> Boxity -> Arity -> OccName +mkTupleOcc ns bx ar + = OccName ns (mkFastString ('Z' : (show ar ++ bx_char))) + where + bx_char = case bx of + Boxed -> "T" + Unboxed -> "H" + +isTupleOcc_maybe :: OccName -> Maybe (NameSpace, Boxity, Arity) +-- Tuples are special, because there are so many of them! +isTupleOcc_maybe (OccName ns fs) + = case unpackFS fs of + ('Z':d:rest) | isDigit d -> Just (decode_tup (digitToInt d) rest) + other -> Nothing + where + decode_tup n "H" = (ns, Unboxed, n) + decode_tup n "T" = (ns, Boxed, n) + decode_tup n (d:rest) = decode_tup (n*10 + digitToInt d) rest +\end{code} %************************************************************************ %* * @@ -718,8 +870,15 @@ isUpperISO (C# c#) = c# `geChar#` '\xc0'# && c# `leChar#` '\xde'# && c# `neCh isLowerISO (C# c#) = c# `geChar#` '\xdf'# && c# `leChar#` '\xff'# && c# `neChar#` '\xf7'# --0xdf <= oc && oc <= 0xff && oc /= 0xf7 where oc = ord c \end{code} + +%************************************************************************ +%* * + Binary instance + Here rather than BinIface because OccName is abstract +%* * +%************************************************************************ + \begin{code} -{-* Generated by DrIFT-v1.0 : Look, but Don't Touch. *-} instance Binary NameSpace where put_ bh VarName = do putByte bh 0 @@ -745,7 +904,4 @@ instance Binary OccName where aa <- get bh ab <- get bh return (OccName aa ab) - --- Imported from other files :- - \end{code} diff --git a/ghc/compiler/basicTypes/RdrName.lhs b/ghc/compiler/basicTypes/RdrName.lhs index 1c93ca1302..f743100fee 100644 --- a/ghc/compiler/basicTypes/RdrName.lhs +++ b/ghc/compiler/basicTypes/RdrName.lhs @@ -1,4 +1,3 @@ -{-% DrIFT (Automatic class derivations for Haskell) v1.1 %-} % % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % @@ -7,45 +6,57 @@ \begin{code} module RdrName ( - RdrName, + RdrName(..), -- Constructors exported only to BinIface -- Construction mkRdrUnqual, mkRdrQual, - mkUnqual, mkQual, mkOrig, mkIfaceOrig, + mkUnqual, mkVarUnqual, mkQual, mkOrig, mkIfaceOrig, nameRdrName, getRdrName, - qualifyRdrName, unqualifyRdrName, mkRdrNameWkr, + qualifyRdrName, unqualifyRdrName, + mkDerivedRdrName, dummyRdrVarName, dummyRdrTcName, -- Destruction rdrNameModule, rdrNameOcc, setRdrNameSpace, isRdrDataCon, isRdrTyVar, isRdrTc, isQual, isUnqual, - isOrig, isExact, isExact_maybe, - - -- Environment - RdrNameEnv, - emptyRdrEnv, lookupRdrEnv, addListToRdrEnv, rdrEnvElts, - extendRdrEnv, rdrEnvToList, elemRdrEnv, foldRdrEnv, + isOrig, isOrig_maybe, isExact, isExact_maybe, isSrcRdrName, -- Printing; instance Outputable RdrName - pprUnqualRdrName + pprUnqualRdrName, + + -- LocalRdrEnv + LocalRdrEnv, emptyLocalRdrEnv, extendLocalRdrEnv, + lookupLocalRdrEnv, elemLocalRdrEnv, + + -- GlobalRdrEnv + GlobalRdrEnv, emptyGlobalRdrEnv, mkGlobalRdrEnv, plusGlobalRdrEnv, + lookupGlobalRdrEnv, pprGlobalRdrEnv, globalRdrEnvElts, + lookupGRE_RdrName, lookupGRE_Name, + + -- GlobalRdrElt, Provenance, ImportSpec + GlobalRdrElt(..), Provenance(..), ImportSpec(..), + isLocalGRE, unQualOK, hasQual, + pprNameProvenance ) where #include "HsVersions.h" -import OccName ( NameSpace, tcName, +import OccName ( NameSpace, tcName, varName, OccName, UserFS, EncodedFS, mkSysOccFS, setOccNameSpace, mkOccFS, mkVarOcc, occNameFlavour, - isDataOcc, isTvOcc, isTcOcc, mkWorkerOcc - ) -import Module ( ModuleName, - mkSysModuleNameFS, mkModuleNameFS + isDataOcc, isTvOcc, isTcOcc, + OccEnv, emptyOccEnv, extendOccEnvList, lookupOccEnv, + elemOccEnv, plusOccEnv_C, extendOccEnv_C, foldOccEnv, + occEnvElts ) -import Name ( Name, NamedThing(getName), nameModule, nameOccName ) -import Module ( moduleName ) -import FiniteMap +import Module ( ModuleName, mkSysModuleNameFS, mkModuleNameFS ) +import Name ( Name, NamedThing(getName), nameModuleName, nameParent_maybe, + nameOccName, isExternalName, nameSrcLoc ) +import Maybes ( seqMaybe ) +import SrcLoc ( SrcLoc, isGoodSrcLoc ) +import BasicTypes( DeprecTxt ) import Outputable -import Binary import Util ( thenCmp ) \end{code} @@ -77,7 +88,10 @@ data RdrName -- We know exactly the Name. This is used -- (a) when the parser parses built-in syntax like "[]" -- and "(,)", but wants a RdrName from it - -- (b) possibly, by the meta-programming stuff + -- (b) when converting names to the RdrNames in IfaceTypes + -- Here an Exact RdrName always contains an External Name + -- (Internal Names are converted to simple Unquals) + -- (c) possibly, by the meta-programming stuff \end{code} @@ -91,7 +105,7 @@ data RdrName rdrNameModule :: RdrName -> ModuleName rdrNameModule (Qual m _) = m rdrNameModule (Orig m _) = m -rdrNameModule (Exact n) = moduleName (nameModule n) +rdrNameModule (Exact n) = nameModuleName n rdrNameModule (Unqual n) = pprPanic "rdrNameModule" (ppr n) rdrNameOcc :: RdrName -> OccName @@ -112,7 +126,8 @@ setRdrNameSpace :: RdrName -> NameSpace -> RdrName 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)) +setRdrNameSpace (Exact n) ns = Orig (nameModuleName n) + (setOccNameSpace ns (nameOccName n)) \end{code} \begin{code} @@ -129,20 +144,31 @@ mkOrig mod occ = Orig mod occ mkIfaceOrig :: NameSpace -> EncodedFS -> EncodedFS -> RdrName mkIfaceOrig ns m n = Orig (mkSysModuleNameFS m) (mkSysOccFS ns n) +--------------- +mkDerivedRdrName :: Name -> (OccName -> OccName) -> (RdrName) +mkDerivedRdrName parent mk_occ + = mkOrig (nameModuleName parent) (mk_occ (nameOccName parent)) +--------------- -- These two are used when parsing source files -- They do encode the module and occurrence names mkUnqual :: NameSpace -> UserFS -> RdrName mkUnqual sp n = Unqual (mkOccFS sp n) +mkVarUnqual :: UserFS -> RdrName +mkVarUnqual n = Unqual (mkOccFS varName n) + mkQual :: NameSpace -> (UserFS, UserFS) -> RdrName mkQual sp (m, n) = Qual (mkModuleNameFS m) (mkOccFS sp n) getRdrName :: NamedThing thing => thing -> RdrName -getRdrName name = Exact (getName name) +getRdrName name = nameRdrName (getName name) nameRdrName :: Name -> RdrName nameRdrName name = Exact name +-- Keep the Name even for Internal names, so that the +-- unique is still there for debug printing, particularly +-- of Types (which are converted to IfaceTypes before printing) qualifyRdrName :: ModuleName -> RdrName -> RdrName -- Sets the module name of a RdrName, even if it has one already @@ -151,12 +177,10 @@ qualifyRdrName mod rn = Qual mod (rdrNameOcc rn) unqualifyRdrName :: RdrName -> RdrName unqualifyRdrName rdr_name = Unqual (rdrNameOcc rdr_name) -mkRdrNameWkr :: RdrName -> RdrName -- Worker-ify it -mkRdrNameWkr rdr_name = Qual (rdrNameModule rdr_name) - (mkWorkerOcc (rdrNameOcc rdr_name)) - -origFromName :: Name -> RdrName -origFromName n = Orig (moduleName (nameModule n)) (nameOccName n) +nukeExact :: Name -> RdrName +nukeExact n + | isExternalName n = Orig (nameModuleName n) (nameOccName n) + | otherwise = Unqual (nameOccName n) \end{code} \begin{code} @@ -175,6 +199,10 @@ isRdrDataCon rn = isDataOcc (rdrNameOcc rn) isRdrTyVar rn = isTvOcc (rdrNameOcc rn) isRdrTc rn = isTcOcc (rdrNameOcc rn) +isSrcRdrName (Unqual _) = True +isSrcRdrName (Qual _ _) = True +isSrcRdrName _ = False + isUnqual (Unqual _) = True isUnqual other = False @@ -184,6 +212,9 @@ isQual _ = False isOrig (Orig _ _) = True isOrig _ = False +isOrig_maybe (Orig m n) = Just (m,n) +isOrig_maybe _ = Nothing + isExact (Exact _) = True isExact other = False @@ -215,8 +246,15 @@ instance OutputableBndr RdrName where pprUnqualRdrName rdr_name = ppr (rdrNameOcc rdr_name) instance Eq RdrName where - a == b = case (a `compare` b) of { EQ -> True; _ -> False } - a /= b = case (a `compare` b) of { EQ -> False; _ -> True } + (Exact n1) == (Exact n2) = n1==n2 + -- Convert exact to orig + (Exact n1) == r2@(Orig _ _) = nukeExact n1 == r2 + r1@(Orig _ _) == (Exact n2) = r1 == nukeExact n2 + + (Orig m1 o1) == (Orig m2 o2) = m1==m2 && o1==o2 + (Qual m1 o1) == (Qual m2 o2) = m1==m2 && o1==o2 + (Unqual o1) == (Unqual o2) = o1==o2 + r1 == r2 = False instance Ord RdrName where a <= b = case (a `compare` b) of { LT -> True; EQ -> True; GT -> False } @@ -224,16 +262,18 @@ instance Ord RdrName where a >= b = case (a `compare` b) of { LT -> False; EQ -> True; GT -> True } a > b = case (a `compare` b) of { LT -> False; EQ -> False; GT -> True } - -- Unqual < Qual < Orig < Exact - compare (Exact n1) (Exact n2) = n1 `compare` n2 + -- Unqual < Qual < Orig + -- We always convert Exact to Orig before comparing + compare (Exact n1) (Exact n2) | n1==n2 = EQ -- Short cut + | otherwise = nukeExact n1 `compare` nukeExact n2 + compare (Exact n1) n2 = nukeExact n1 `compare` n2 + compare n1 (Exact n2) = n1 `compare` nukeExact n2 + + compare (Qual m1 o1) (Qual m2 o2) = (o1 `compare` o2) `thenCmp` (m1 `compare` m2) compare (Orig m1 o1) (Orig m2 o2) = (o1 `compare` o2) `thenCmp` (m1 `compare` m2) compare (Unqual o1) (Unqual o2) = o1 `compare` o2 - -- Convert Exact to Orig - compare (Exact n1) n2 = origFromName n1 `compare` n2 - compare n1 (Exact n2) = n1 `compare` origFromName n2 - compare (Unqual _) _ = LT compare (Qual _ _) (Orig _ _) = LT compare _ _ = GT @@ -243,59 +283,228 @@ instance Ord RdrName where %************************************************************************ %* * -\subsection{Environment} + LocalRdrEnv +%* * +%************************************************************************ + +A LocalRdrEnv is used for local bindings (let, where, lambda, case) +It is keyed by OccName, because we never use it for qualified names. + +\begin{code} +type LocalRdrEnv = OccEnv Name + +emptyLocalRdrEnv = emptyOccEnv + +extendLocalRdrEnv :: LocalRdrEnv -> [Name] -> LocalRdrEnv +extendLocalRdrEnv env names + = extendOccEnvList env [(nameOccName n, n) | n <- names] + +lookupLocalRdrEnv :: LocalRdrEnv -> RdrName -> Maybe Name +lookupLocalRdrEnv env rdr_name + | isUnqual rdr_name = lookupOccEnv env (rdrNameOcc rdr_name) + | otherwise = Nothing + +elemLocalRdrEnv :: RdrName -> LocalRdrEnv -> Bool +elemLocalRdrEnv rdr_name env + | isUnqual rdr_name = rdrNameOcc rdr_name `elemOccEnv` env + | otherwise = False +\end{code} + + +%************************************************************************ +%* * + GlobalRdrEnv +%* * +%************************************************************************ + +\begin{code} +type GlobalRdrEnv = OccEnv [GlobalRdrElt] + -- Keyed by OccName; when looking up a qualified name + -- we look up the OccName part, and then check the Provenance + -- to see if the appropriate qualification is valid. This + -- saves routinely doubling the size of the env by adding both + -- qualified and unqualified names to the domain. + -- + -- The list in the range is reqd because there may be name clashes + -- These only get reported on lookup, not on construction + + -- INVARIANT: All the members of the list have distinct + -- gre_name fields; that is, no duplicate Names + +emptyGlobalRdrEnv = emptyOccEnv + +globalRdrEnvElts :: GlobalRdrEnv -> [GlobalRdrElt] +globalRdrEnvElts env = foldOccEnv (++) [] env + +data GlobalRdrElt + = GRE { gre_name :: Name, + gre_prov :: Provenance, -- Why it's in scope + gre_deprec :: Maybe DeprecTxt -- Whether this name is deprecated + } + +instance Outputable GlobalRdrElt where + ppr gre = ppr name <+> pp_parent (nameParent_maybe name) + <+> parens (pprNameProvenance gre) + where + name = gre_name gre + pp_parent (Just p) = brackets (text "parent:" <+> ppr p) + pp_parent Nothing = empty + +pprGlobalRdrEnv :: GlobalRdrEnv -> SDoc +pprGlobalRdrEnv env + = vcat (map pp (occEnvElts env)) + where + pp gres = ppr (nameOccName (gre_name (head gres))) <> colon <+> + vcat [ ppr (gre_name gre) <+> pprNameProvenance gre + | gre <- gres] +\end{code} + +\begin{code} +lookupGlobalRdrEnv :: GlobalRdrEnv -> OccName -> [GlobalRdrElt] +lookupGlobalRdrEnv env rdr_name = case lookupOccEnv env rdr_name of + Nothing -> [] + Just gres -> gres + +lookupGRE_RdrName :: RdrName -> GlobalRdrEnv -> [GlobalRdrElt] +lookupGRE_RdrName rdr_name env + = case lookupOccEnv env occ of + Nothing -> [] + Just gres | isUnqual rdr_name -> filter unQualOK gres + | otherwise -> filter (hasQual mod) gres + where + mod = rdrNameModule rdr_name + occ = rdrNameOcc rdr_name + +lookupGRE_Name :: GlobalRdrEnv -> Name -> [GlobalRdrElt] +lookupGRE_Name env name + = [ gre | gre <- lookupGlobalRdrEnv env (nameOccName name), + gre_name gre == name ] + + +isLocalGRE :: GlobalRdrElt -> Bool +isLocalGRE (GRE {gre_prov = LocalDef _}) = True +isLocalGRE other = False + +unQualOK :: GlobalRdrElt -> Bool +-- An unqualifed version of this thing is in scope +unQualOK (GRE {gre_prov = LocalDef _}) = True +unQualOK (GRE {gre_prov = Imported is _}) = not (all is_qual is) + +hasQual :: ModuleName -> GlobalRdrElt -> Bool +-- A qualified version of this thing is in scope +hasQual mod (GRE {gre_prov = LocalDef m}) = m == mod +hasQual mod (GRE {gre_prov = Imported is _}) = any ((== mod) . is_as) is + +plusGlobalRdrEnv :: GlobalRdrEnv -> GlobalRdrEnv -> GlobalRdrEnv +plusGlobalRdrEnv env1 env2 = plusOccEnv_C (foldr insertGRE) env1 env2 + +mkGlobalRdrEnv :: [GlobalRdrElt] -> GlobalRdrEnv +mkGlobalRdrEnv gres + = foldr add emptyGlobalRdrEnv gres + where + add gre env = extendOccEnv_C (foldr insertGRE) env + (nameOccName (gre_name gre)) + [gre] + +insertGRE :: GlobalRdrElt -> [GlobalRdrElt] -> [GlobalRdrElt] +insertGRE new_g [] = [new_g] +insertGRE new_g (old_g : old_gs) + | gre_name new_g == gre_name old_g + = new_g `plusGRE` old_g : old_gs + | otherwise + = old_g : insertGRE new_g old_gs + +plusGRE :: GlobalRdrElt -> GlobalRdrElt -> GlobalRdrElt +-- Used when the gre_name fields match +plusGRE g1 g2 + = GRE { gre_name = gre_name g1, + gre_prov = gre_prov g1 `plusProv` gre_prov g2, + gre_deprec = gre_deprec g1 `seqMaybe` gre_deprec g2 } + -- Could the deprecs be different? If we re-export + -- something deprecated, is it propagated? I forget. +\end{code} + + +%************************************************************************ +%* * + Provenance %* * %************************************************************************ +The "provenance" of something says how it came to be in scope. + \begin{code} -type RdrNameEnv a = FiniteMap RdrName a - -emptyRdrEnv :: RdrNameEnv a -lookupRdrEnv :: RdrNameEnv a -> RdrName -> Maybe a -addListToRdrEnv :: RdrNameEnv a -> [(RdrName,a)] -> RdrNameEnv a -extendRdrEnv :: RdrNameEnv a -> RdrName -> a -> RdrNameEnv a -rdrEnvToList :: RdrNameEnv a -> [(RdrName, a)] -rdrEnvElts :: RdrNameEnv a -> [a] -elemRdrEnv :: RdrName -> RdrNameEnv a -> Bool -foldRdrEnv :: (RdrName -> a -> b -> b) -> b -> RdrNameEnv a -> b - -emptyRdrEnv = emptyFM -lookupRdrEnv = lookupFM -addListToRdrEnv = addListToFM -rdrEnvElts = eltsFM -extendRdrEnv = addToFM -rdrEnvToList = fmToList -elemRdrEnv = elemFM -foldRdrEnv = foldFM +data Provenance + = LocalDef -- Defined locally + ModuleName + + | Imported -- Imported + [ImportSpec] -- INVARIANT: non-empty + Bool -- True iff the thing was named *explicitly* + -- in *any* of the import specs rather than being + -- imported as part of a group; + -- e.g. + -- import B + -- import C( T(..) ) + -- Here, everything imported by B, and the constructors of T + -- are not named explicitly; only T is named explicitly. + -- This info is used when warning of unused names. + +data ImportSpec -- Describes a particular import declaration + -- Shared among all the Provenaces for a particular + -- import declaration + = ImportSpec { + is_mod :: ModuleName, -- 'import Muggle' + -- Note the Muggle may well not be + -- the defining module for this thing! + is_as :: ModuleName, -- 'as M' (or 'Muggle' if there is no 'as' clause) + is_qual :: Bool, -- True <=> qualified (only) + is_loc :: SrcLoc } -- Location of import statment + +-- Comparison of provenance is just used for grouping +-- error messages (in RnEnv.warnUnusedBinds) +instance Eq Provenance where + p1 == p2 = case p1 `compare` p2 of EQ -> True; _ -> False + +instance Eq ImportSpec where + p1 == p2 = case p1 `compare` p2 of EQ -> True; _ -> False + +instance Ord Provenance where + compare (LocalDef _) (LocalDef _) = EQ + compare (LocalDef _) (Imported _ _) = LT + compare (Imported _ _) (LocalDef _) = GT + compare (Imported is1 _) (Imported is2 _) = compare (head is1) (head is2) + +instance Ord ImportSpec where + compare is1 is2 = (is_mod is1 `compare` is_mod is2) `thenCmp` + (is_loc is1 `compare` is_loc is2) \end{code} \begin{code} -instance Binary RdrName where - put_ bh (Unqual aa) = do - putByte bh 0 - put_ bh aa - - put_ bh (Qual aa ab) = do - putByte bh 1 - put_ bh aa - put_ bh ab - - put_ bh (Orig aa ab) = do - putByte bh 2 - put_ bh aa - put_ bh ab - - put_ bh (Exact n) = pprPanic "No Binary instance for RdrName.Exact" (ppr n) - - get bh = do - h <- getByte bh - case h of - 0 -> do aa <- get bh - return (Unqual aa) - 1 -> do aa <- get bh - ab <- get bh - return (Qual aa ab) - _ -> do aa <- get bh - ab <- get bh - return (Orig aa ab) +plusProv :: Provenance -> Provenance -> Provenance +-- Choose LocalDef over Imported +-- There is an obscure bug lurking here, in the presence +-- of recursive modules, something can be imported *and* locally +-- defined, and one might refer to it with a qualified name from +-- the import -- but I'm going to ignore that because it makes +-- the isLocalGRE predicate so much nicer this way +plusProv (LocalDef m1) (LocalDef m2) + = pprPanic "plusProv" (ppr m1 <+> ppr m2) +plusProv p1@(LocalDef _) p2 = p1 +plusProv p1 p2@(LocalDef _) = p2 +plusProv (Imported is1 ex1) (Imported is2 ex2) + = Imported (is1++is2) (ex1 || ex2) + +pprNameProvenance :: GlobalRdrElt -> SDoc +pprNameProvenance (GRE {gre_name = name, gre_prov = LocalDef _}) + = ptext SLIT("defined at") <+> ppr (nameSrcLoc name) +pprNameProvenance (GRE {gre_name = name, gre_prov = Imported (why:whys) _}) + = sep [ppr_reason why, nest 2 (ppr_defn (nameSrcLoc name))] + +ppr_reason imp_spec + = ptext SLIT("imported from") <+> ppr (is_mod imp_spec) + <+> ptext SLIT("at") <+> ppr (is_loc imp_spec) + +ppr_defn loc | isGoodSrcLoc loc = parens (ptext SLIT("defined at") <+> ppr loc) + | otherwise = empty \end{code} diff --git a/ghc/compiler/basicTypes/SrcLoc.lhs b/ghc/compiler/basicTypes/SrcLoc.lhs index 377a8c872d..cd3513568c 100644 --- a/ghc/compiler/basicTypes/SrcLoc.lhs +++ b/ghc/compiler/basicTypes/SrcLoc.lhs @@ -11,13 +11,14 @@ module SrcLoc ( SrcLoc, -- Abstract - mkSrcLoc, isGoodSrcLoc, isWiredInLoc, + mkSrcLoc, isGoodSrcLoc, mkGeneralSrcLoc, noSrcLoc, -- "I'm sorry, I haven't a clue" advanceSrcLoc, importedSrcLoc, -- Unknown place in an interface wiredInSrcLoc, -- Something wired into the compiler generatedSrcLoc, -- Code generated within the compiler + interactiveSrcLoc, -- Code from an interactive session srcLocFile, -- return the file name part srcLocLine, -- return the line part @@ -28,7 +29,6 @@ module SrcLoc ( import Util ( thenCmp ) import Outputable -import FastString ( unpackFS ) import FastTypes import FastString @@ -45,17 +45,13 @@ We keep information about the {\em definition} point for each entity; this is the obvious stuff: \begin{code} data SrcLoc - = WiredInLoc -- Used exclusively for Ids and TyCons - -- that are totally wired in to the - -- compiler. That supports the - -- occasionally-useful predicate - -- isWiredInName - - | SrcLoc FastString -- A precise location (file name) + = SrcLoc FastString -- A precise location (file name) FastInt -- line FastInt -- column - | UnhelpfulSrcLoc FastString -- Just a general indication + | ImportedLoc String -- Module name + + | UnhelpfulLoc FastString -- Just a general indication {- data SrcSpan @@ -86,30 +82,37 @@ rare case. Things to make 'em: \begin{code} mkSrcLoc x line col = SrcLoc x (iUnbox line) (iUnbox col) -wiredInSrcLoc = WiredInLoc -noSrcLoc = UnhelpfulSrcLoc FSLIT("<No locn>") -importedSrcLoc = UnhelpfulSrcLoc FSLIT("<imported>") -generatedSrcLoc = UnhelpfulSrcLoc FSLIT("<compiler-generated-code>") +noSrcLoc = UnhelpfulLoc FSLIT("<no locn>") +generatedSrcLoc = UnhelpfulLoc FSLIT("<compiler-generated code>") +wiredInSrcLoc = UnhelpfulLoc FSLIT("<wired into compiler>") +interactiveSrcLoc = UnhelpfulLoc FSLIT("<interactive session>") -isGoodSrcLoc (SrcLoc _ _ _) = True -isGoodSrcLoc other = False +mkGeneralSrcLoc :: FastString -> SrcLoc +mkGeneralSrcLoc = UnhelpfulLoc -isWiredInLoc WiredInLoc = True -isWiredInLoc other = False +importedSrcLoc :: String -> SrcLoc +importedSrcLoc mod_name = ImportedLoc mod_name + +isGoodSrcLoc (SrcLoc _ _ _) = True +isGoodSrcLoc other = False srcLocFile :: SrcLoc -> FastString srcLocFile (SrcLoc fname _ _) = fname +srcLocFile other = FSLIT("<unknown file") srcLocLine :: SrcLoc -> Int srcLocLine (SrcLoc _ l c) = iBox l +srcLocLine other = panic "srcLocLine: unknown line" srcLocCol :: SrcLoc -> Int srcLocCol (SrcLoc _ l c) = iBox c +srcLocCol other = panic "srcLocCol: unknown col" advanceSrcLoc :: SrcLoc -> Char -> SrcLoc advanceSrcLoc (SrcLoc f l c) '\t' = SrcLoc f l (tab c) advanceSrcLoc (SrcLoc f l c) '\n' = SrcLoc f (l +# 1#) 0# advanceSrcLoc (SrcLoc f l c) _ = SrcLoc f l (c +# 1#) +advanceSrcLoc loc _ = loc -- Better than nothing -- Advance to the next tab stop. Tabs are at column positions 0, 8, 16, etc. tab :: FastInt -> FastInt @@ -132,21 +135,21 @@ instance Eq SrcLoc where instance Ord SrcLoc where compare = cmpSrcLoc -cmpSrcLoc WiredInLoc WiredInLoc = EQ -cmpSrcLoc WiredInLoc other = LT +cmpSrcLoc (UnhelpfulLoc s1) (UnhelpfulLoc s2) = s1 `compare` s2 +cmpSrcLoc (UnhelpfulLoc _) other = LT -cmpSrcLoc (UnhelpfulSrcLoc s1) (UnhelpfulSrcLoc s2) = s1 `compare` s2 -cmpSrcLoc (UnhelpfulSrcLoc s1) other = GT +cmpSrcLoc (ImportedLoc _) (UnhelpfulLoc _) = GT +cmpSrcLoc (ImportedLoc m1) (ImportedLoc m2) = m1 `compare` m2 +cmpSrcLoc (ImportedLoc _) other = LT -cmpSrcLoc (SrcLoc _ _ _) WiredInLoc = GT -cmpSrcLoc (SrcLoc _ _ _) (UnhelpfulSrcLoc _) = LT cmpSrcLoc (SrcLoc s1 l1 c1) (SrcLoc s2 l2 c2) = (s1 `compare` s2) `thenCmp` (l1 `cmpline` l2) `thenCmp` (c1 `cmpline` c2) where l1 `cmpline` l2 | l1 <# l2 = LT | l1 ==# l2 = EQ | otherwise = GT - +cmpSrcLoc (SrcLoc _ _ _) other = GT + instance Outputable SrcLoc where ppr (SrcLoc src_path src_line src_col) = getPprStyle $ \ sty -> @@ -158,10 +161,7 @@ instance Outputable SrcLoc where else hcat [text "{-# LINE ", int (iBox src_line), space, char '\"', ftext src_path, text " #-}"] - where - src_file = unpackFS src_path -- Leave the directory prefix intact, - -- so emacs can find the file - ppr (UnhelpfulSrcLoc s) = ftext s - ppr WiredInLoc = ptext SLIT("<Wired in>") + ppr (ImportedLoc mod) = ptext SLIT("Imported from") <+> quotes (text mod) + ppr (UnhelpfulLoc s) = ftext s \end{code} diff --git a/ghc/compiler/codeGen/CgCon.lhs b/ghc/compiler/codeGen/CgCon.lhs index 6752a3b79b..47ac572ddf 100644 --- a/ghc/compiler/codeGen/CgCon.lhs +++ b/ghc/compiler/codeGen/CgCon.lhs @@ -26,30 +26,27 @@ import CgBindery ( getArgAmodes, bindNewToNode, idInfoToAmode, stableAmodeIdInfo, heapIdInfo, CgIdInfo, bindNewToStack ) -import CgStackery ( mkVirtStkOffsets, freeStackSlots, updateFrameSize ) -import CgUsages ( getRealSp, getVirtSp, setRealAndVirtualSp, - getSpRelOffset ) +import CgStackery ( mkVirtStkOffsets, freeStackSlots ) +import CgUsages ( getRealSp, getVirtSp, setRealAndVirtualSp ) import CgRetConv ( assignRegs ) -import Constants ( mAX_INTLIKE, mIN_INTLIKE, mAX_CHARLIKE, mIN_CHARLIKE, - mIN_UPD_SIZE ) +import Constants ( mAX_INTLIKE, mIN_INTLIKE, mAX_CHARLIKE, mIN_CHARLIKE ) import CgHeapery ( allocDynClosure ) import CgTailCall ( performReturn, mkStaticAlgReturnCode, returnUnboxedTuple ) import CLabel ( mkClosureLabel ) import ClosureInfo ( mkConLFInfo, mkLFArgument, layOutDynConstr, - layOutStaticConstr, closureSize, mkStaticClosure + layOutStaticConstr, mkStaticClosure ) import CostCentre ( currentOrSubsumedCCS, dontCareCCS, CostCentreStack, currentCCS ) import DataCon ( DataCon, dataConTag, - isUnboxedTupleCon, isNullaryDataCon, dataConWorkId, + isUnboxedTupleCon, dataConWorkId, dataConName, dataConRepArity ) import Id ( Id, idName, idPrimRep, isDeadBinder ) import Literal ( Literal(..) ) import PrelInfo ( maybeCharLikeCon, maybeIntLikeCon ) import PrimRep ( PrimRep(..), isFollowableRep ) -import Unique ( Uniquable(..) ) import Util import Outputable diff --git a/ghc/compiler/codeGen/CgRetConv.lhs b/ghc/compiler/codeGen/CgRetConv.lhs index 825d748c05..ecf7d52ae9 100644 --- a/ghc/compiler/codeGen/CgRetConv.lhs +++ b/ghc/compiler/codeGen/CgRetConv.lhs @@ -1,7 +1,7 @@ % % (c) The GRASP Project, Glasgow University, 1992-1998 % -% $Id: CgRetConv.lhs,v 1.33 2002/09/13 15:02:28 simonpj Exp $ +% $Id: CgRetConv.lhs,v 1.34 2003/10/09 11:58:46 simonpj Exp $ % \section[CgRetConv]{Return conventions for the code generator} @@ -26,7 +26,7 @@ import Constants ( mAX_FAMILY_SIZE_FOR_VEC_RETURNS, mAX_Real_Double_REG, mAX_Real_Long_REG ) import CmdLineOpts ( opt_Unregisterised ) -import Maybes ( catMaybes ) +import Maybes ( mapCatMaybes ) import PrimRep ( isFloatingRep, PrimRep(..), is64BitRep ) import TyCon ( TyCon, tyConFamilySize ) import Util ( isn'tIn ) @@ -224,10 +224,10 @@ mkRegTbl_allRegs regs_in_use mkRegTbl' regs_in_use vanillas floats doubles longs = (ok_vanilla, ok_float, ok_double, ok_long) where - ok_vanilla = catMaybes (map (select (VanillaReg VoidRep)) vanillas) - ok_float = catMaybes (map (select FloatReg) floats) - ok_double = catMaybes (map (select DoubleReg) doubles) - ok_long = catMaybes (map (select (LongReg Int64Rep)) longs) + ok_vanilla = mapCatMaybes (select (VanillaReg VoidRep)) vanillas + ok_float = mapCatMaybes (select FloatReg) floats + ok_double = mapCatMaybes (select DoubleReg) doubles + ok_long = mapCatMaybes (select (LongReg Int64Rep)) longs -- rep isn't looked at, hence we can use any old rep. select :: (FastInt -> MagicId) -> Int{-cand-} -> Maybe Int diff --git a/ghc/compiler/codeGen/ClosureInfo.lhs b/ghc/compiler/codeGen/ClosureInfo.lhs index 16639d4a16..89678d5e87 100644 --- a/ghc/compiler/codeGen/ClosureInfo.lhs +++ b/ghc/compiler/codeGen/ClosureInfo.lhs @@ -1,7 +1,7 @@ % % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % -% $Id: ClosureInfo.lhs,v 1.58 2003/06/09 13:17:38 matthewc Exp $ +% $Id: ClosureInfo.lhs,v 1.59 2003/10/09 11:58:46 simonpj Exp $ % \section[ClosureInfo]{Data structures which describe closures} @@ -89,6 +89,8 @@ import Bitmap import Maybe ( isJust ) import DATA_BITS + +import TypeRep -- TEMP \end{code} %************************************************************************ diff --git a/ghc/compiler/codeGen/CodeGen.lhs b/ghc/compiler/codeGen/CodeGen.lhs index 5b01138cd8..4ac0eaa557 100644 --- a/ghc/compiler/codeGen/CodeGen.lhs +++ b/ghc/compiler/codeGen/CodeGen.lhs @@ -300,7 +300,7 @@ maybeExternaliseId id | opt_EnsureSplittableC, -- Externalise the name for -split-objs isInternalName name = moduleName `thenFC` \ mod -> - returnFC (setIdName id (mkExternalName uniq mod new_occ (nameSrcLoc name))) + returnFC (setIdName id (mkExternalName uniq mod new_occ Nothing (nameSrcLoc name))) | otherwise = returnFC id where diff --git a/ghc/compiler/compMan/CompManager.lhs b/ghc/compiler/compMan/CompManager.lhs index 1722ddcd47..149e225efb 100644 --- a/ghc/compiler/compMan/CompManager.lhs +++ b/ghc/compiler/compMan/CompManager.lhs @@ -8,9 +8,9 @@ module CompManager ( ModuleGraph, ModSummary(..), - CmState, emptyCmState, -- abstract + CmState, -- abstract - cmInit, -- :: GhciMode -> IO CmState + cmInit, -- :: GhciMode -> DynFlags -> IO CmState cmDepAnal, -- :: CmState -> DynFlags -> [FilePath] -> IO ModuleGraph @@ -46,6 +46,7 @@ module CompManager ( cmGetModInfo, -- :: CmState -> (ModuleGraph, HomePackageTable) findModuleLinkable_maybe, -- Exported to InteractiveUI + cmSetDFlags, cmGetBindings, -- :: CmState -> [TyThing] cmGetPrintUnqual, -- :: CmState -> PrintUnqualified @@ -57,13 +58,11 @@ where #include "HsVersions.h" import DriverPipeline ( CompResult(..), preprocess, compile, link ) +import HscMain ( newHscEnv ) import DriverState ( v_Output_file, v_NoHsMain ) import DriverPhases -import DriverUtil import Finder -import HscMain ( initPersistentCompilerState ) -import HscTypes hiding ( moduleNameToModule ) -import NameEnv +import HscTypes import PrelNames ( gHC_PRIM_Name ) import Module ( Module, ModuleName, moduleName, mkModuleName, isHomeModule, ModuleEnv, lookupModuleEnvByName, mkModuleEnv, moduleEnvElts, @@ -80,19 +79,20 @@ import Util import Outputable import Panic import CmdLineOpts ( DynFlags(..), getDynFlags ) -import Maybes ( expectJust, orElse ) +import Maybes ( expectJust, orElse, mapCatMaybes ) import DATA_IOREF ( readIORef ) #ifdef GHCI import HscMain ( hscThing, hscStmt, hscTcExpr ) -import Module ( moduleUserString ) -import TcRnDriver ( mkGlobalContext, getModuleContents ) -import Name ( Name, NamedThing(..), isExternalName, nameModule ) +import TcRnDriver ( mkExportEnv, getModuleContents ) +import IfaceSyn ( IfaceDecl ) +import Name ( Name ) +import NameEnv import Id ( idType ) import Type ( tidyType ) import VarEnv ( emptyTidyEnv ) -import BasicTypes ( Fixity, FixitySig(..), defaultFixity ) +import BasicTypes ( Fixity ) import Linker ( HValue, unload, extendLinkEnv ) import GHC.Exts ( unsafeCoerce# ) import Foreign @@ -115,31 +115,31 @@ import Time ( ClockTime ) -- Persistent state for the entire system data CmState = CmState { - gmode :: GhciMode, -- NEVER CHANGES - - hpt :: HomePackageTable, -- Info about home package module - mg :: ModuleGraph, -- the module graph - ic :: InteractiveContext, -- command-line binding info - - pcs :: PersistentCompilerState -- compile's persistent state + cm_hsc :: HscEnv, -- Includes the home-package table + cm_mg :: ModuleGraph, -- The module graph + cm_ic :: InteractiveContext -- Command-line binding info } -cmGetModInfo cmstate = (mg cmstate, hpt cmstate) -cmGetBindings cmstate = nameEnvElts (ic_type_env (ic cmstate)) -cmGetPrintUnqual cmstate = icPrintUnqual (ic cmstate) - -emptyCmState :: GhciMode -> IO CmState -emptyCmState gmode - = do pcs <- initPersistentCompilerState - return (CmState { hpt = emptyHomePackageTable, - mg = emptyMG, - gmode = gmode, - ic = emptyInteractiveContext, - pcs = pcs }) +#ifdef GHCI +cmGetModInfo cmstate = (cm_mg cmstate, hsc_HPT (cm_hsc cmstate)) +cmGetBindings cmstate = nameEnvElts (ic_type_env (cm_ic cmstate)) +cmGetPrintUnqual cmstate = icPrintUnqual (cm_ic cmstate) +cmHPT cmstate = hsc_HPT (cm_hsc cmstate) +#endif -cmInit :: GhciMode -> IO CmState -cmInit mode = emptyCmState mode +cmInit :: GhciMode -> DynFlags -> IO CmState +cmInit ghci_mode dflags + = do { hsc_env <- newHscEnv ghci_mode dflags + ; return (CmState { cm_hsc = hsc_env, + cm_mg = emptyMG, + cm_ic = emptyInteractiveContext })} +discardCMInfo :: CmState -> CmState +-- Forget the compilation manager's state, including the home package table +-- but retain the persistent info in HscEnv +discardCMInfo cm_state + = cm_state { cm_mg = emptyMG, cm_ic = emptyInteractiveContext, + cm_hsc = (cm_hsc cm_state) { hsc_HPT = emptyHomePackageTable } } ------------------------------------------------------------------- -- The unlinked image @@ -150,8 +150,6 @@ cmInit mode = emptyCmState mode -- recompiling. type UnlinkedImage = [Linkable] -- the unlinked images (should be a set, really) -emptyUI :: UnlinkedImage -emptyUI = [] findModuleLinkable_maybe :: [Linkable] -> ModuleName -> Maybe Linkable findModuleLinkable_maybe lis mod @@ -159,21 +157,6 @@ findModuleLinkable_maybe lis mod [] -> Nothing [li] -> Just li many -> pprPanic "findModuleLinkable" (ppr mod) - -filterModuleLinkables :: (ModuleName -> Bool) -> [Linkable] -> [Linkable] -filterModuleLinkables p [] = [] -filterModuleLinkables p (li:lis) - = case li of - LM _ modnm _ -> if p modnm then retain else dump - where - dump = filterModuleLinkables p lis - retain = li : dump - -linkableInSet :: Linkable -> [Linkable] -> Bool -linkableInSet l objs_loaded = - case findModuleLinkable_maybe objs_loaded (linkableModName l) of - Nothing -> False - Just m -> linkableTime l == linkableTime m \end{code} @@ -191,106 +174,54 @@ linkableInSet l objs_loaded = -- module. They always shadow anything in scope in the current context. cmSetContext - :: CmState -> DynFlags + :: CmState -> [String] -- take the top-level scopes of these modules -> [String] -- and the just the exports from these -> IO CmState -cmSetContext cmstate dflags toplevs exports = do - let CmState{ hpt=hpt, pcs=pcs, ic=old_ic } = cmstate - hsc_env = HscEnv { hsc_mode = Interactive, hsc_dflags = dflags, - hsc_HPT = hpt } - - toplev_mods <- mapM (getTopLevModule hpt) (map mkModuleName toplevs) - export_mods <- mapM (moduleNameToModule hpt) (map mkModuleName exports) - - (new_pcs, maybe_env) - <- mkGlobalContext hsc_env pcs toplev_mods export_mods - - case maybe_env of - Nothing -> return cmstate - Just env -> return cmstate{ pcs = new_pcs, - ic = old_ic{ ic_toplev_scope = toplev_mods, - ic_exports = export_mods, - ic_rn_gbl_env = env } } - -getTopLevModule hpt mn = - case lookupModuleEnvByName hpt mn of - - Just mod_info - | isJust (mi_globals iface) -> return (mi_module iface) - where - iface = hm_iface mod_info - - _other -> throwDyn (CmdLineError ( - "cannot enter the top-level scope of a compiled module (module `" ++ - moduleNameUserString mn ++ "')")) - -moduleNameToModule :: HomePackageTable -> ModuleName -> IO Module -moduleNameToModule hpt mn = do - case lookupModuleEnvByName hpt mn of - Just mod_info -> return (mi_module (hm_iface mod_info)) - _not_a_home_module -> do - maybe_stuff <- findModule mn - case maybe_stuff of - Left _ -> throwDyn (CmdLineError ("can't find module `" - ++ moduleNameUserString mn ++ "'")) - Right (m,_) -> return m +cmSetContext cmstate toplevs exports = do + let old_ic = cm_ic cmstate + + export_env <- mkExportEnv (cm_hsc cmstate) + (map mkModuleName exports) + + putStrLn (showSDoc (text "export env" $$ ppr export_env)) + return cmstate{ cm_ic = old_ic { ic_toplev_scope = toplevs, + ic_exports = exports, + ic_rn_gbl_env = export_env } } cmGetContext :: CmState -> IO ([String],[String]) -cmGetContext CmState{ic=ic} = - return (map moduleUserString (ic_toplev_scope ic), - map moduleUserString (ic_exports ic)) +cmGetContext CmState{cm_ic=ic} = + return (ic_toplev_scope ic, ic_exports ic) cmModuleIsInterpreted :: CmState -> String -> IO Bool cmModuleIsInterpreted cmstate str - = case lookupModuleEnvByName (hpt cmstate) (mkModuleName str) of - Just details -> return (isJust (mi_globals (hm_iface details))) + = case lookupModuleEnvByName (cmHPT cmstate) (mkModuleName str) of + Just details -> return (isJust (hm_globals details)) _not_a_home_module -> return False ----------------------------------------------------------------------------- +cmSetDFlags :: CmState -> DynFlags -> CmState +cmSetDFlags cm_state dflags + = cm_state { cm_hsc = (cm_hsc cm_state) { hsc_dflags = dflags } } + +----------------------------------------------------------------------------- -- cmInfoThing: convert a String to a TyThing -- A string may refer to more than one TyThing (eg. a constructor, -- and type constructor), so we return a list of all the possible TyThings. -cmInfoThing :: CmState -> DynFlags -> String -> IO (CmState, [(TyThing,Fixity)]) -cmInfoThing cmstate dflags id - = do (new_pcs, things) <- hscThing hsc_env pcs icontext id - let new_pit = eps_PIT (pcs_EPS new_pcs) - pairs = map (\x -> (x, getFixity new_pit (getName x))) things - return (cmstate{ pcs=new_pcs }, pairs) - where - CmState{ hpt=hpt, pcs=pcs, ic=icontext } = cmstate - hsc_env = HscEnv { hsc_mode = Interactive, - hsc_dflags = dflags, - hsc_HPT = hpt } - - getFixity :: PackageIfaceTable -> Name -> Fixity - getFixity pit name - | isExternalName name, - Just iface <- lookupIface hpt pit (nameModule name), - Just (FixitySig _ fixity _) <- lookupNameEnv (mi_fixities iface) name - = fixity - | otherwise - = defaultFixity +cmInfoThing :: CmState -> String -> IO [(IfaceDecl,Fixity)] +cmInfoThing cmstate id + = hscThing (cm_hsc cmstate) (cm_ic cmstate) id -- --------------------------------------------------------------------------- -- cmBrowseModule: get all the TyThings defined in a module -cmBrowseModule :: CmState -> DynFlags -> String -> Bool - -> IO (CmState, [TyThing]) -cmBrowseModule cmstate dflags str exports_only = do - let mn = mkModuleName str - mod <- moduleNameToModule hpt mn - (pcs1, maybe_ty_things) - <- getModuleContents hsc_env pcs mod exports_only - case maybe_ty_things of - Nothing -> return (cmstate{pcs=pcs1}, []) - Just ty_things -> return (cmstate{pcs=pcs1}, ty_things) - where - hsc_env = HscEnv { hsc_mode = Interactive, hsc_dflags = dflags, - hsc_HPT = hpt } - CmState{ hpt=hpt, pcs=pcs, ic=icontext } = cmstate +cmBrowseModule :: CmState -> String -> Bool -> IO [IfaceDecl] +cmBrowseModule cmstate str exports_only + = getModuleContents (cm_hsc cmstate) (cm_ic cmstate) + (mkModuleName str) exports_only + ----------------------------------------------------------------------------- -- cmRunStmt: Run a statement/expr. @@ -300,19 +231,13 @@ data CmRunResult | CmRunFailed | CmRunException Exception -- statement raised an exception -cmRunStmt :: CmState -> DynFlags -> String -> IO (CmState, CmRunResult) -cmRunStmt cmstate@CmState{ hpt=hpt, pcs=pcs, ic=icontext } - dflags expr +cmRunStmt :: CmState -> String -> IO (CmState, CmRunResult) +cmRunStmt cmstate@CmState{ cm_hsc=hsc_env, cm_ic=icontext } expr = do - let hsc_env = HscEnv { hsc_mode = Interactive, - hsc_dflags = dflags, - hsc_HPT = hpt } - - (new_pcs, maybe_stuff) - <- hscStmt hsc_env pcs icontext expr + maybe_stuff <- hscStmt hsc_env icontext expr case maybe_stuff of - Nothing -> return (cmstate{ pcs=new_pcs }, CmRunFailed) + Nothing -> return (cmstate, CmRunFailed) Just (new_ic, names, hval) -> do let thing_to_run = unsafeCoerce# hval :: IO [HValue] @@ -323,7 +248,7 @@ cmRunStmt cmstate@CmState{ hpt=hpt, pcs=pcs, ic=icontext } -- on error, keep the *old* interactive context, -- so that 'it' is not bound to something -- that doesn't exist. - return ( cmstate{ pcs=new_pcs }, CmRunException e ) + return ( cmstate, CmRunException e ) Right hvals -> do -- Get the newly bound things, and bind them. @@ -331,7 +256,7 @@ cmRunStmt cmstate@CmState{ hpt=hpt, pcs=pcs, ic=icontext } -- the new ones override the old ones. extendLinkEnv (zip names hvals) - return (cmstate{ pcs=new_pcs, ic=new_ic }, + return (cmstate{ cm_ic=new_ic }, CmRunOk names) @@ -373,36 +298,28 @@ foreign import "rts_evalStableIO" {- safe -} ----------------------------------------------------------------------------- -- cmTypeOfExpr: returns a string representing the type of an expression -cmTypeOfExpr :: CmState -> DynFlags -> String -> IO (CmState, Maybe String) -cmTypeOfExpr cmstate dflags expr - = do (new_pcs, maybe_stuff) <- hscTcExpr hsc_env pcs ic expr - - let new_cmstate = cmstate{pcs = new_pcs} +cmTypeOfExpr :: CmState -> String -> IO (Maybe String) +cmTypeOfExpr cmstate expr + = do maybe_stuff <- hscTcExpr (cm_hsc cmstate) (cm_ic cmstate) expr case maybe_stuff of - Nothing -> return (new_cmstate, Nothing) - Just ty -> return (new_cmstate, Just str) + Nothing -> return Nothing + Just ty -> return (Just str) where str = showSDocForUser unqual (text expr <+> dcolon <+> ppr tidy_ty) - unqual = icPrintUnqual ic + unqual = icPrintUnqual (cm_ic cmstate) tidy_ty = tidyType emptyTidyEnv ty - where - CmState{ hpt=hpt, pcs=pcs, ic=ic } = cmstate - hsc_env = HscEnv { hsc_mode = Interactive, - hsc_dflags = dflags, - hsc_HPT = hpt } - ----------------------------------------------------------------------------- -- cmTypeOfName: returns a string representing the type of a name. cmTypeOfName :: CmState -> Name -> IO (Maybe String) -cmTypeOfName CmState{ pcs=pcs, ic=ic } name +cmTypeOfName CmState{ cm_ic=ic } name = do hPutStrLn stderr ("cmTypeOfName: " ++ showSDoc (ppr name)) case lookupNameEnv (ic_type_env ic) name of - Nothing -> return Nothing + Nothing -> return Nothing Just (AnId id) -> return (Just str) where unqual = icPrintUnqual ic @@ -414,30 +331,24 @@ cmTypeOfName CmState{ pcs=pcs, ic=ic } name ----------------------------------------------------------------------------- -- cmCompileExpr: compile an expression and deliver an HValue -cmCompileExpr :: CmState -> DynFlags -> String -> IO (CmState, Maybe HValue) -cmCompileExpr cmstate dflags expr +cmCompileExpr :: CmState -> String -> IO (Maybe HValue) +cmCompileExpr cmstate expr = do - let hsc_env = HscEnv { hsc_mode = Interactive, - hsc_dflags = dflags, - hsc_HPT = hpt } - - (new_pcs, maybe_stuff) - <- hscStmt hsc_env pcs icontext + maybe_stuff + <- hscStmt (cm_hsc cmstate) (cm_ic cmstate) ("let __cmCompileExpr = "++expr) case maybe_stuff of - Nothing -> return (cmstate{ pcs=new_pcs }, Nothing) + Nothing -> return Nothing Just (new_ic, names, hval) -> do -- Run it! hvals <- (unsafeCoerce# hval) :: IO [HValue] case (names,hvals) of - ([n],[hv]) -> return (cmstate{ pcs=new_pcs }, Just hv) + ([n],[hv]) -> return (Just hv) _ -> panic "cmCompileExpr" - where - CmState{ hpt=hpt, pcs=pcs, ic=icontext } = cmstate #endif /* GHCI */ \end{code} @@ -453,26 +364,26 @@ cmCompileExpr cmstate dflags expr -- Unload the compilation manager's state: everything it knows about the -- current collection of modules in the Home package. -cmUnload :: CmState -> DynFlags -> IO CmState -cmUnload state@CmState{ gmode=mode, pcs=pcs } dflags +cmUnload :: CmState -> IO CmState +cmUnload state@CmState{ cm_hsc = hsc_env } = do -- Throw away the old home dir cache flushFinderCache -- Unload everything the linker knows about - cm_unload mode dflags [] + cm_unload hsc_env [] -- Start with a fresh CmState, but keep the PersistentCompilerState - new_state <- cmInit mode - return new_state{ pcs=pcs } - -cm_unload Batch dflags linkables = return () + return (discardCMInfo state) +cm_unload hsc_env linkables + = case hsc_mode hsc_env of + Batch -> return () #ifdef GHCI -cm_unload Interactive dflags linkables = Linker.unload dflags linkables + Interactive -> Linker.unload (hsc_dflags hsc_env) linkables #else -cm_unload Interactive dflags linkables = panic "unload: no interpreter" + Interactive -> panic "unload: no interpreter" #endif - + ----------------------------------------------------------------------------- -- Trace dependency graph @@ -485,14 +396,18 @@ cm_unload Interactive dflags linkables = panic "unload: no interpreter" -- He wants to do the dependency analysis before the unload, so that -- if the former fails he can use the later -cmDepAnal :: CmState -> DynFlags -> [FilePath] -> IO ModuleGraph -cmDepAnal cmstate dflags rootnames +cmDepAnal :: CmState -> [FilePath] -> IO ModuleGraph +cmDepAnal cmstate rootnames = do showPass dflags "Chasing dependencies" - when (verbosity dflags >= 1 && gmode cmstate == Batch) $ + when (verbosity dflags >= 1 && gmode == Batch) $ hPutStrLn stderr (showSDoc (hcat [ text "Chasing modules from: ", hcat (punctuate comma (map text rootnames))])) - downsweep rootnames (mg cmstate) + downsweep rootnames (cm_mg cmstate) + where + hsc_env = cm_hsc cmstate + dflags = hsc_dflags hsc_env + gmode = hsc_mode hsc_env ----------------------------------------------------------------------------- -- The real business of the compilation manager: given a system state and @@ -500,18 +415,17 @@ cmDepAnal cmstate dflags rootnames -- the system state at the same time. cmLoadModules :: CmState -- The HPT may not be as up to date - -> DynFlags -- as the ModuleGraph -> ModuleGraph -- Bang up to date -> IO (CmState, -- new state SuccessFlag, -- was successful [String]) -- list of modules loaded -cmLoadModules cmstate1 dflags mg2unsorted +cmLoadModules cmstate1 mg2unsorted = do -- version 1's are the original, before downsweep - let pcs1 = pcs cmstate1 - let hpt1 = hpt cmstate1 - - let ghci_mode = gmode cmstate1 -- this never changes + let hsc_env = cm_hsc cmstate1 + let hpt1 = hsc_HPT hsc_env + let ghci_mode = hsc_mode hsc_env -- this never changes + let dflags = hsc_dflags hsc_env -- this never changes -- Do the downsweep to reestablish the module graph let verb = verbosity dflags @@ -545,6 +459,7 @@ cmLoadModules cmstate1 dflags mg2unsorted -- Uniq of ModuleName is the same as Module, fortunately... let hpt2 = delListFromUFM hpt1 (map linkableModName new_linkables) + hsc_env2 = hsc_env { hsc_HPT = hpt2 } -- When (verb >= 2) $ -- putStrLn (showSDoc (text "Valid linkables:" @@ -576,7 +491,7 @@ cmLoadModules cmstate1 dflags mg2unsorted -- Unload any modules which are going to be re-linked this -- time around. - cm_unload ghci_mode dflags stable_linkables + cm_unload hsc_env2 stable_linkables -- we can now glom together our linkable sets let valid_linkables = valid_old_linkables ++ new_linkables @@ -601,17 +516,13 @@ cmLoadModules cmstate1 dflags mg2unsorted -- Now do the upsweep, calling compile for each module in -- turn. Final result is version 3 of everything. - let threaded2 = CmThreaded pcs1 hpt2 - -- clean up between compilations let cleanup = cleanTempFilesExcept verb (ppFilesFromSummaries (flattenSCCs mg2)) - (upsweep_ok, threaded3, modsUpswept) - <- upsweep_mods ghci_mode dflags valid_linkables reachable_from - threaded2 cleanup upsweep_these - - let (CmThreaded pcs3 hpt3) = threaded3 + (upsweep_ok, hsc_env3, modsUpswept) + <- upsweep_mods hsc_env2 valid_linkables reachable_from + cleanup upsweep_these -- At this point, modsUpswept and newLis should have the same -- length, so there is one new (or old) linkable for each @@ -653,10 +564,10 @@ cmLoadModules cmstate1 dflags mg2unsorted hPutStrLn stderr "Warning: output was redirected with -o, but no output will be generated\nbecause there is no Main module." -- link everything together - linkresult <- link ghci_mode dflags do_linking hpt3 + linkresult <- link ghci_mode dflags do_linking (hsc_HPT hsc_env3) - cmLoadFinish Succeeded linkresult - hpt3 modsDone ghci_mode pcs3 + let cmstate3 = cmstate1 { cm_mg = modsDone, cm_hsc = hsc_env3 } + cmLoadFinish Succeeded linkresult cmstate3 else -- Tricky. We need to back out the effects of compiling any @@ -674,7 +585,8 @@ cmLoadModules cmstate1 dflags mg2unsorted = filter ((`notElem` mods_to_zap_names).modSummaryName) modsDone - let hpt4 = retainInTopLevelEnvs (map modSummaryName mods_to_keep) hpt3 + let hpt4 = retainInTopLevelEnvs (map modSummaryName mods_to_keep) + (hsc_HPT hsc_env3) -- Clean up after ourselves cleanTempFilesExcept verb (ppFilesFromSummaries mods_to_keep) @@ -682,26 +594,24 @@ cmLoadModules cmstate1 dflags mg2unsorted -- Link everything together linkresult <- link ghci_mode dflags False hpt4 - cmLoadFinish Failed linkresult - hpt4 mods_to_keep ghci_mode pcs3 + let cmstate3 = cmstate1 { cm_mg = mods_to_keep, + cm_hsc = hsc_env3 { hsc_HPT = hpt4 } } + cmLoadFinish Failed linkresult cmstate3 -- Finish up after a cmLoad. -- If the link failed, unload everything and return. -cmLoadFinish ok Failed hpt mods ghci_mode pcs = do - dflags <- getDynFlags - cm_unload ghci_mode dflags [] - new_state <- cmInit ghci_mode - return (new_state{ pcs=pcs }, Failed, []) +cmLoadFinish ok Failed cmstate + = do cm_unload (cm_hsc cmstate) [] + return (discardCMInfo cmstate, Failed, []) -- Empty the interactive context and set the module context to the topmost -- newly loaded module, or the Prelude if none were loaded. -cmLoadFinish ok Succeeded hpt mods ghci_mode pcs - = do let new_cmstate = CmState{ hpt=hpt, mg=mods, - gmode=ghci_mode, pcs=pcs, - ic = emptyInteractiveContext } - mods_loaded = map (moduleNameUserString.modSummaryName) mods +cmLoadFinish ok Succeeded cmstate + = do let new_cmstate = cmstate { cm_ic = emptyInteractiveContext } + mods_loaded = map (moduleNameUserString.modSummaryName) + (cm_mg cmstate) return (new_cmstate, ok, mods_loaded) @@ -928,72 +838,62 @@ findPartiallyCompletedCycles modsDone theGraph else chewed_rest -data CmThreaded -- stuff threaded through individual module compilations - = CmThreaded PersistentCompilerState HomePackageTable - - -- Compile multiple modules, stopping as soon as an error appears. -- There better had not be any cyclic groups here -- we check for them. -upsweep_mods :: GhciMode - -> DynFlags +upsweep_mods :: HscEnv -- Includes up-to-date HPT -> [Linkable] -- Valid linkables -> (ModuleName -> [ModuleName]) -- to construct downward closures - -> CmThreaded -- PCS & HPT -> IO () -- how to clean up unwanted tmp files -> [SCC ModSummary] -- mods to do (the worklist) -- ...... RETURNING ...... -> IO (SuccessFlag, - CmThreaded, -- Includes linkables + HscEnv, -- With an updated HPT [ModSummary]) -- Mods which succeeded -upsweep_mods ghci_mode dflags oldUI reachable_from threaded cleanup +upsweep_mods hsc_env oldUI reachable_from cleanup [] - = return (Succeeded, threaded, []) + = return (Succeeded, hsc_env, []) -upsweep_mods ghci_mode dflags oldUI reachable_from threaded cleanup +upsweep_mods hsc_env oldUI reachable_from cleanup ((CyclicSCC ms):_) = do hPutStrLn stderr ("Module imports form a cycle for modules:\n\t" ++ unwords (map (moduleNameUserString.modSummaryName) ms)) - return (Failed, threaded, []) + return (Failed, hsc_env, []) -upsweep_mods ghci_mode dflags oldUI reachable_from threaded cleanup +upsweep_mods hsc_env oldUI reachable_from cleanup ((AcyclicSCC mod):mods) - = do --case threaded of - -- CmThreaded pcsz hptz - -- -> putStrLn ("UPSWEEP_MOD: hpt = " ++ - -- show (map (moduleNameUserString.moduleName.mi_module.hm_iface) (eltsUFM hptz))) + = do -- putStrLn ("UPSWEEP_MOD: hpt = " ++ + -- show (map (moduleNameUserString.moduleName.mi_module.hm_iface) (eltsUFM (hsc_HPT hsc_env))) - (ok_flag, threaded1) <- upsweep_mod ghci_mode dflags oldUI threaded mod + (ok_flag, hsc_env1) <- upsweep_mod hsc_env oldUI mod (reachable_from (modSummaryName mod)) cleanup -- Remove unwanted tmp files between compilations if failed ok_flag then - return (Failed, threaded1, []) + return (Failed, hsc_env1, []) else do - (restOK, threaded2, modOKs) - <- upsweep_mods ghci_mode dflags oldUI reachable_from - threaded1 cleanup mods - return (restOK, threaded2, mod:modOKs) + (restOK, hsc_env2, modOKs) + <- upsweep_mods hsc_env1 oldUI reachable_from cleanup mods + return (restOK, hsc_env2, mod:modOKs) -- Compile a single module. Always produce a Linkable for it if -- successful. If no compilation happened, return the old Linkable. -upsweep_mod :: GhciMode - -> DynFlags +upsweep_mod :: HscEnv -> UnlinkedImage - -> CmThreaded -> ModSummary -> [ModuleName] - -> IO (SuccessFlag, CmThreaded) + -> IO (SuccessFlag, + HscEnv) -- With updated HPT -upsweep_mod ghci_mode dflags oldUI threaded1 summary1 reachable_inc_me +upsweep_mod hsc_env oldUI summary1 reachable_inc_me = do let this_mod = ms_mod summary1 location = ms_location summary1 mod_name = moduleName this_mod + hpt1 = hsc_HPT hsc_env - let (CmThreaded pcs1 hpt1) = threaded1 let mb_old_iface = case lookupModuleEnvByName hpt1 mod_name of Just mod_info -> Just (hm_iface mod_info) Nothing -> Nothing @@ -1007,8 +907,9 @@ upsweep_mod ghci_mode dflags oldUI threaded1 summary1 reachable_inc_me -- interface in the HPT. We never demand-load home interfaces in -- interactive mode. hpt1_strictDC - = ASSERT(ghci_mode == Batch || all (`elemUFM` hpt1) reachable_only) + = ASSERT(hsc_mode hsc_env == Batch || all (`elemUFM` hpt1) reachable_only) retainInTopLevelEnvs reachable_only hpt1 + hsc_env_strictDC = hsc_env { hsc_HPT = hpt1_strictDC } old_linkable = expectJust "upsweep_mod:old_linkable" maybe_old_linkable @@ -1016,26 +917,27 @@ upsweep_mod ghci_mode dflags oldUI threaded1 summary1 reachable_inc_me | Just l <- maybe_old_linkable, isObjectLinkable l = True | otherwise = False - compresult <- compile ghci_mode this_mod location source_unchanged - have_object mb_old_iface hpt1_strictDC pcs1 + compresult <- compile hsc_env_strictDC this_mod location + source_unchanged have_object mb_old_iface case compresult of -- Compilation "succeeded", and may or may not have returned a new -- linkable (depending on whether compilation was actually performed -- or not). - CompOK pcs2 new_details new_iface maybe_new_linkable + CompOK new_details new_globals new_iface maybe_new_linkable -> do let new_linkable = maybe_new_linkable `orElse` old_linkable new_info = HomeModInfo { hm_iface = new_iface, + hm_globals = new_globals, hm_details = new_details, hm_linkable = new_linkable } hpt2 = extendModuleEnv hpt1 this_mod new_info - return (Succeeded, CmThreaded pcs2 hpt2) + return (Succeeded, hsc_env { hsc_HPT = hpt2 }) -- Compilation failed. Compile may still have updated the PCS, tho. - CompErrs pcs2 -> return (Failed, CmThreaded pcs2 hpt1) + CompErrs -> return (Failed, hsc_env) -- Filter modules in the HPT retainInTopLevelEnvs :: [ModuleName] -> HomePackageTable -> HomePackageTable @@ -1089,7 +991,7 @@ topological_sort include_source_imports summaries Nothing -> panic "reverse_topological_sort" Just mk -> (summ, mk, -- ignore imports not from the home package - catMaybes (map (flip lookup key_map) m_imports)) + mapCatMaybes (flip lookup key_map) m_imports) edges = map toEdge summaries key_map = zip [nm | (s,nm,imps) <- edges] [1 ..] :: [(ModuleName,Int)] diff --git a/ghc/compiler/coreSyn/CorePrep.lhs b/ghc/compiler/coreSyn/CorePrep.lhs index 18444b6892..1602a07b86 100644 --- a/ghc/compiler/coreSyn/CorePrep.lhs +++ b/ghc/compiler/coreSyn/CorePrep.lhs @@ -16,7 +16,6 @@ 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 @@ -26,7 +25,7 @@ import Id ( mkSysLocal, idType, idNewDemandInfo, idArity, isLocalId, hasNoBinding, idNewStrictness, idUnfolding, isDataConWorkId_maybe ) -import HscTypes ( TypeEnv, typeEnvElts ) +import HscTypes ( TypeEnv, typeEnvElts, TyThing( AnId ) ) import BasicTypes ( TopLevelFlag(..), isTopLevel, isNotTopLevel, RecFlag(..), isNonRec ) @@ -579,9 +578,6 @@ mkLocalNonRec bndr dem floats rhs = floatRhs NotTopLevel NonRecursive bndr (floats, rhs) `thenUs` \ (floats', rhs') -> returnUs (addFloat floats' (FloatLet (NonRec bndr rhs'))) - where - bndr_ty = idType bndr - mkBinds :: Floats -> CoreExpr -> UniqSM CoreExpr mkBinds (Floats _ binds) body diff --git a/ghc/compiler/coreSyn/CoreSyn.hi-boot-6 b/ghc/compiler/coreSyn/CoreSyn.hi-boot-6 index db6c7550ac..38dc8c7f7e 100644 --- a/ghc/compiler/coreSyn/CoreSyn.hi-boot-6 +++ b/ghc/compiler/coreSyn/CoreSyn.hi-boot-6 @@ -3,4 +3,3 @@ module CoreSyn where -- Needed by Var.lhs data Expr b type CoreExpr = Expr Var.Var - diff --git a/ghc/compiler/coreSyn/CoreUnfold.lhs b/ghc/compiler/coreSyn/CoreUnfold.lhs index 01d7925741..baf76c7225 100644 --- a/ghc/compiler/coreSyn/CoreUnfold.lhs +++ b/ghc/compiler/coreSyn/CoreUnfold.lhs @@ -42,8 +42,7 @@ import PprCore ( pprCoreExpr ) import OccurAnal ( occurAnalyseGlobalExpr ) import CoreUtils ( exprIsValue, exprIsCheap, exprIsTrivial ) import Id ( Id, idType, isId, - idUnfolding, - isFCallId_maybe, globalIdDetails + idUnfolding, globalIdDetails ) import DataCon ( isUnboxedTupleCon ) import Literal ( litSize ) @@ -137,7 +136,7 @@ calcUnfoldingGuidance bOMB_OUT_SIZE expr | not inline -> UnfoldNever -- A big function with an INLINE pragma must -- have an UnfoldIfGoodArgs guidance - | inline -> UnfoldIfGoodArgs n_val_binders + | otherwise -> UnfoldIfGoodArgs n_val_binders (map (const 0) val_binders) max_inline_size 0 diff --git a/ghc/compiler/coreSyn/CoreUtils.lhs b/ghc/compiler/coreSyn/CoreUtils.lhs index 7921b3cfcf..5a82fdda3b 100644 --- a/ghc/compiler/coreSyn/CoreUtils.lhs +++ b/ghc/compiler/coreSyn/CoreUtils.lhs @@ -47,7 +47,7 @@ import Name ( hashName, isDllName ) import Literal ( hashLiteral, literalType, litIsDupable, litIsTrivial, isZeroLit ) import DataCon ( DataCon, dataConRepArity, dataConArgTys, - isExistentialDataCon, dataConTyCon, dataConName ) + isExistentialDataCon, dataConTyCon ) import PrimOp ( PrimOp(..), primOpOkForSpeculation, primOpIsCheap ) import Id ( Id, idType, globalIdDetails, idNewStrictness, mkWildId, idArity, idName, idUnfolding, idInfo, @@ -59,7 +59,7 @@ import NewDemand ( appIsBottom ) import Type ( Type, mkFunTy, mkForAllTy, splitFunTy_maybe, splitFunTy, applyTys, isUnLiftedType, seqType, mkTyVarTy, - splitForAllTy_maybe, isForAllTy, splitNewType_maybe, + splitForAllTy_maybe, isForAllTy, splitRecNewType_maybe, splitTyConApp_maybe, eqType, funResultTy, applyTy, funResultTy, applyTy ) @@ -932,13 +932,15 @@ eta_expand n us expr ty ; Nothing -> -- Given this: - -- newtype T = MkT (Int -> Int) + -- newtype T = MkT ([T] -> Int) -- Consider eta-expanding this -- eta_expand 1 e T -- We want to get - -- coerce T (\x::Int -> (coerce (Int->Int) e) x) + -- coerce T (\x::[T] -> (coerce ([T]->Int) e) x) + -- Only try this for recursive newtypes; the non-recursive kind + -- are transparent anyway - case splitNewType_maybe ty of { + case splitRecNewType_maybe ty of { Just ty' -> mkCoerce2 ty ty' (eta_expand n us (mkCoerce2 ty' ty expr) ty') ; Nothing -> pprTrace "Bad eta expand" (ppr expr $$ ppr ty) expr }}} diff --git a/ghc/compiler/coreSyn/ExternalCore.lhs b/ghc/compiler/coreSyn/ExternalCore.lhs index 06cf07940b..d7eb45579a 100644 --- a/ghc/compiler/coreSyn/ExternalCore.lhs +++ b/ghc/compiler/coreSyn/ExternalCore.lhs @@ -14,13 +14,13 @@ data Tdef | Newtype (Qual Tcon) [Tbind] (Maybe Ty) data Cdef - = Constr (Qual Dcon) [Tbind] [Ty] + = Constr Dcon [Tbind] [Ty] data Vdefg = Rec [Vdef] | Nonrec Vdef -type Vdef = (Qual Var,Ty,Exp) +type Vdef = (Var,Ty,Exp) -- Top level bindings are unqualified now data Exp = Var (Qual Var) diff --git a/ghc/compiler/coreSyn/MkExternalCore.lhs b/ghc/compiler/coreSyn/MkExternalCore.lhs index 86c77da144..66fa9711e3 100644 --- a/ghc/compiler/coreSyn/MkExternalCore.lhs +++ b/ghc/compiler/coreSyn/MkExternalCore.lhs @@ -18,6 +18,7 @@ import TyCon import Class import TypeRep import Type +import PprExternalCore -- Instances import DataCon ( DataCon, dataConExistentialTyVars, dataConRepArgTys, dataConName, dataConWrapId_maybe ) import CoreSyn @@ -28,12 +29,10 @@ import CoreTidy ( tidyExpr ) import VarEnv ( emptyTidyEnv ) import Literal import Name -import CostCentre import Outputable import ForeignCall -import PprExternalCore import CmdLineOpts -import Maybes ( orElse, catMaybes ) +import Maybes ( mapCatMaybes ) import IO import FastString @@ -73,11 +72,11 @@ 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) | isAlgTyCon tc = catMaybes (map dataConWrapId_maybe (tyConDataCons tc)) +implicit_con_ids (ATyCon tc) | isAlgTyCon tc = mapCatMaybes dataConWrapId_maybe (tyConDataCons tc) implicit_con_ids other = [] other_implicit_ids :: TyThing -> [Id] -other_implicit_ids (ATyCon tc) = tyConSelIds tc ++ tyConGenIds tc +other_implicit_ids (ATyCon tc) = tyConSelIds tc other_implicit_ids (AClass cl) = classSelIds cl other_implicit_ids other = [] @@ -110,7 +109,7 @@ collect_tdefs _ tdefs = tdefs make_cdef :: DataCon -> C.Cdef make_cdef dcon = C.Constr dcon_name existentials tys where - dcon_name = make_con_qid (dataConName dcon) + dcon_name = make_var_id (dataConName dcon) existentials = map make_tbind ex_tyvars ex_tyvars = dataConExistentialTyVars dcon tys = map make_ty (dataConRepArgTys dcon) @@ -126,7 +125,8 @@ make_vdef b = case b of NonRec v e -> C.Nonrec (f (v,e)) Rec ves -> C.Rec (map f ves) - where f (v,e) = (make_var_qid (Var.varName v), make_ty (varType v),make_exp e) + where f (v,e) = (make_var_id (Var.varName v), make_ty (varType v),make_exp e) + -- Top level bindings are unqualified now make_exp :: CoreExpr -> C.Exp make_exp (Var v) = @@ -187,7 +187,7 @@ make_ty (ForAllTy tv t) = C.Tforall (make_tbind tv) (make_ty t) make_ty (TyConApp tc ts) = foldl C.Tapp (C.Tcon (make_con_qid (tyConName tc))) (map make_ty ts) -- The special case for newtypes says "do not expand newtypes". --- Reason: sourceTypeRep does substitution and, while substitution deals +-- Reason: predTypeRep does substitution and, while substitution deals -- correctly with name capture, it's only correct if you see the uniques! -- If you just see occurrence names, name capture may occur. -- Example: newtype A a = A (forall b. b -> a) @@ -198,11 +198,11 @@ make_ty (TyConApp tc ts) = foldl C.Tapp (C.Tcon (make_con_qid (tyConName tc))) -- expose the representation in interface files, which definitely isn't right. -- Maybe CoreTidy should know whether to expand newtypes or not? -make_ty (SourceTy (NType tc ts)) = foldl C.Tapp (C.Tcon (make_con_qid (tyConName tc))) +make_ty (NewTcApp tc ts) = foldl C.Tapp (C.Tcon (make_con_qid (tyConName tc))) (map make_ty ts) -make_ty (SourceTy p) = make_ty (sourceTypeRep p) -make_ty (NoteTy _ t) = make_ty t +make_ty (PredTy p) = make_ty (predTypeRep p) +make_ty (NoteTy _ t) = make_ty t diff --git a/ghc/compiler/coreSyn/PprCore.lhs b/ghc/compiler/coreSyn/PprCore.lhs index 2d62772859..09bb56e092 100644 --- a/ghc/compiler/coreSyn/PprCore.lhs +++ b/ghc/compiler/coreSyn/PprCore.lhs @@ -258,8 +258,6 @@ ppr_case_pat con args pprArg (Type ty) = ptext SLIT("@") <+> pprParendType ty pprArg expr = pprParendExpr expr - -arrow = ptext SLIT("->") \end{code} Other printing bits-and-bobs used with the general @pprCoreBinding@ diff --git a/ghc/compiler/coreSyn/PprExternalCore.lhs b/ghc/compiler/coreSyn/PprExternalCore.lhs index 73536fa99d..357780d295 100644 --- a/ghc/compiler/coreSyn/PprExternalCore.lhs +++ b/ghc/compiler/coreSyn/PprExternalCore.lhs @@ -55,12 +55,12 @@ ptdef (Newtype tcon tbinds rep ) = Nothing -> empty pcdef (Constr dcon tbinds tys) = - (pqname dcon) <+> (sep [hsep (map pattbind tbinds),sep (map paty tys)]) + (pname dcon) <+> (sep [hsep (map pattbind tbinds),sep (map paty tys)]) pname id = text id pqname ("",id) = pname id -pqname (m,id) = pname m <> char '.' <> pname id +pqname (m,id) = pname m <> char '.' <> pname id ptbind (t,Klifted) = pname t ptbind (t,k) = parens (pname t <> text "::" <> pkind k) @@ -96,7 +96,7 @@ pforall tbs t = hsep (map ptbind tbs) <+> char '.' <+> pty t pvdefg (Rec vtes) = text "%rec" $$ braces (indent (vcat (punctuate (char ';') (map pvte vtes)))) pvdefg (Nonrec vte) = pvte vte -pvte (v,t,e) = sep [pqname v <+> text "::" <+> pty t <+> char '=', +pvte (v,t,e) = sep [pname v <+> text "::" <+> pty t <+> char '=', indent (pexp e)] paexp (Var x) = pqname x diff --git a/ghc/compiler/coreSyn/Subst.lhs b/ghc/compiler/coreSyn/Subst.lhs index c406f926e0..1994caa358 100644 --- a/ghc/compiler/coreSyn/Subst.lhs +++ b/ghc/compiler/coreSyn/Subst.lhs @@ -44,7 +44,7 @@ import CoreSyn ( Expr(..), Bind(..), Note(..), CoreExpr, ) import CoreFVs ( exprFreeVars ) import TypeRep ( Type(..), TyNote(..) ) -- friend -import Type ( ThetaType, SourceType(..), PredType, +import Type ( ThetaType, PredType(..), tyVarsOfType, tyVarsOfTypes, mkAppTy, ) import VarSet @@ -58,8 +58,7 @@ import IdInfo ( IdInfo, vanillaIdInfo, specInfo, setSpecInfo, setArityInfo, unknownArity, arityInfo, unfoldingInfo, setUnfoldingInfo, - WorkerInfo(..), workerExists, workerInfo, setWorkerInfo, WorkerInfo, - lbvarInfo, LBVarInfo(..), setLBVarInfo, hasNoLBVarInfo + WorkerInfo(..), workerExists, workerInfo, setWorkerInfo, WorkerInfo ) import BasicTypes ( OccInfo(..) ) import Unique ( Unique, Uniquable(..), deriveUnique ) @@ -427,11 +426,8 @@ substTheta subst theta | otherwise = map (substPred subst) theta substPred :: TyVarSubst -> PredType -> PredType -substPred = substSourceType - -substSourceType subst (IParam n ty) = IParam n (subst_ty subst ty) -substSourceType subst (ClassP clas tys) = ClassP clas (map (subst_ty subst) tys) -substSourceType subst (NType tc tys) = NType tc (map (subst_ty subst) tys) +substPred subst (IParam n ty) = IParam n (subst_ty subst ty) +substPred subst (ClassP clas tys) = ClassP clas (map (subst_ty subst) tys) subst_ty subst ty = go ty @@ -439,7 +435,10 @@ subst_ty subst ty go (TyConApp tc tys) = let args = map go tys in args `seqList` TyConApp tc args - go (SourceTy p) = SourceTy $! (substSourceType subst p) + go (NewTcApp tc tys) = let args = map go tys + in args `seqList` NewTcApp tc args + + go (PredTy p) = PredTy $! (substPred subst p) go (NoteTy (SynNote ty1) ty2) = NoteTy (SynNote $! (go ty1)) $! (go ty2) go (NoteTy (FTVNote _) ty2) = go ty2 -- Discard the free tyvar note @@ -632,8 +631,7 @@ simplIdInfo subst old_info \begin{code} -- substBndr and friends are used when doing expression substitution only -- In this case we can *preserve* occurrence information, and indeed we *want* --- to do so else lose useful occ info in rules. Hence the calls to --- simpl_id with keepOccInfo +-- to do so else lose useful occ info in rules. substBndr :: Subst -> Var -> (Subst, Var) substBndr subst bndr @@ -651,8 +649,6 @@ substRecBndrs subst bndrs -- Here's the reason we need to pass rec_subst to subst_id (new_subst, new_bndrs) = mapAccumL (subst_id True {- keep fragile info -} new_subst) subst bndrs - -keepOccInfo occ = False -- Never fragile \end{code} @@ -747,7 +743,6 @@ substIdInfo :: Bool -- True <=> keep even fragile info -- Substitute the -- rules -- worker info --- LBVar info -- Zap the unfolding -- If keep_fragile then -- keep OccInfo diff --git a/ghc/compiler/deSugar/Desugar.lhs b/ghc/compiler/deSugar/Desugar.lhs index 5b93642612..67c6261ebe 100644 --- a/ghc/compiler/deSugar/Desugar.lhs +++ b/ghc/compiler/deSugar/Desugar.lhs @@ -9,9 +9,9 @@ module Desugar ( deSugar, deSugarExpr ) where #include "HsVersions.h" import CmdLineOpts ( DynFlag(..), dopt, opt_SccProfilingOn ) -import HscTypes ( ModGuts(..), ModGuts, HscEnv(..), ExternalPackageState(..), - PersistentCompilerState(..), Dependencies(..), TypeEnv, GlobalRdrEnv, - lookupType, unQualInScope ) +import HscTypes ( ModGuts(..), ModGuts, HscEnv(..), + Dependencies(..), TypeEnv, + unQualInScope ) import HsSyn ( MonoBinds, RuleDecl(..), RuleBndr(..), HsExpr(..), HsBinds(..), MonoBinds(..) ) import TcHsSyn ( TypecheckedRuleDecl, TypecheckedHsExpr ) @@ -27,9 +27,10 @@ import DsBinds ( dsMonoBinds, AutoScc(..) ) import DsForeign ( dsForeigns ) import DsExpr () -- Forces DsExpr to be compiled; DsBinds only -- depends on DsExpr.hi-boot. -import Module ( Module, moduleEnvElts ) +import Module ( Module, moduleEnvElts, emptyModuleEnv ) import Id ( Id ) -import NameEnv ( lookupNameEnv ) +import RdrName ( GlobalRdrEnv ) +import NameSet import VarEnv import VarSet import Bag ( isEmptyBag, mapBag, emptyBag ) @@ -39,10 +40,9 @@ import ErrUtils ( doIfSet, dumpIfSet_dyn, pprBagOfWarnings, import Outputable import qualified Pretty import UniqSupply ( mkSplitUniqSupply ) -import Maybes ( orElse ) import SrcLoc ( SrcLoc ) -import FastString import DATA_IOREF ( readIORef ) +import FastString \end{code} %************************************************************************ @@ -52,36 +52,36 @@ import DATA_IOREF ( readIORef ) %************************************************************************ \begin{code} -deSugar :: HscEnv -> PersistentCompilerState - -> TcGblEnv -> IO (Maybe ModGuts) - -deSugar hsc_env pcs - (TcGblEnv { tcg_mod = mod, - tcg_type_env = type_env, - tcg_usages = usage_var, - tcg_imports = imports, - tcg_exports = exports, - tcg_rdr_env = rdr_env, - tcg_fix_env = fix_env, - tcg_deprecs = deprecs, - tcg_insts = insts, - tcg_binds = binds, - tcg_fords = fords, - tcg_rules = rules }) +deSugar :: HscEnv -> TcGblEnv -> IO (Maybe ModGuts) +-- Can modify PCS by faulting in more declarations + +deSugar hsc_env + (TcGblEnv { tcg_mod = mod, + tcg_type_env = type_env, + tcg_imports = imports, + tcg_exports = exports, + tcg_dus = dus, + tcg_inst_uses = dfun_uses_var, + tcg_rdr_env = rdr_env, + tcg_fix_env = fix_env, + tcg_deprecs = deprecs, + tcg_insts = insts, + tcg_binds = binds, + tcg_fords = fords, + tcg_rules = rules }) = do { showPass dflags "Desugar" - ; us <- mkSplitUniqSupply 'd' - ; usages <- readIORef usage_var -- Do desugaring - ; let ((ds_binds, ds_rules, ds_fords), ds_warns) - = initDs dflags us lookup mod - (dsProgram binds rules fords) - - warns = mapBag mk_warn ds_warns - warn_doc = pprBagOfWarnings warns + ; let { is_boot = imp_dep_mods imports } + ; (results, warnings) <- initDs hsc_env mod type_env is_boot $ + dsProgram binds rules fords + + ; let { (ds_binds, ds_rules, ds_fords) = results + ; warns = mapBag mk_warn warnings + ; warn_doc = pprBagOfWarnings warns } -- Display any warnings - ; doIfSet (not (isEmptyBag ds_warns)) + ; doIfSet (not (isEmptyBag warnings)) (printErrs warn_doc) -- if warnings are considered errors, leave. @@ -96,6 +96,9 @@ deSugar hsc_env pcs ; doIfSet (dopt Opt_D_dump_ds dflags) (printDump (ppr_ds_rules ds_rules)) + ; dfun_uses <- readIORef dfun_uses_var -- What dfuns are used + ; let used_names = allUses dus emptyNameSet `unionNameSets` dfun_uses + ; usages <- mkUsageInfo hsc_env imports used_names ; let deps = Deps { dep_mods = moduleEnvElts (imp_dep_mods imports), dep_pkgs = imp_dep_pkgs imports, @@ -104,7 +107,7 @@ deSugar hsc_env pcs mg_module = mod, mg_exports = exports, mg_deps = deps, - mg_usages = mkUsageInfo hsc_env eps imports usages, + mg_usages = usages, mg_dir_imps = [m | (m,_) <- moduleEnvElts (imp_mods imports)], mg_rdr_env = rdr_env, mg_fix_env = fix_env, @@ -127,38 +130,25 @@ deSugar hsc_env pcs mk_warn :: (SrcLoc,SDoc) -> (SrcLoc, Pretty.Doc) mk_warn (loc, sdoc) = addShortWarnLocLine loc print_unqual sdoc - -- The lookup function passed to initDs is used for well-known Ids, - -- such as fold, build, cons etc, so the chances are - -- it'll be found in the package symbol table. That's - -- why we don't merge all these tables - eps = pcs_EPS pcs - pte = eps_PTE eps - hpt = hsc_HPT hsc_env - lookup n = case lookupType hpt pte n of { - Just v -> v ; - other -> - case lookupNameEnv type_env n of - Just v -> v ; - other -> pprPanic "Desugar: lookup:" (ppr n) - } deSugarExpr :: HscEnv - -> PersistentCompilerState -> Module -> GlobalRdrEnv -> TypeEnv -> TypecheckedHsExpr -> IO CoreExpr -deSugarExpr hsc_env pcs this_mod rdr_env type_env tc_expr +deSugarExpr hsc_env this_mod rdr_env type_env tc_expr = do { showPass dflags "Desugar" ; us <- mkSplitUniqSupply 'd' -- Do desugaring - ; let (core_expr, ds_warns) = initDs dflags us lookup this_mod (dsExpr tc_expr) - warn_doc = pprBagOfWarnings (mapBag mk_warn ds_warns) + ; let { is_boot = emptyModuleEnv } -- Assume no hi-boot files when + -- doing stuff from the command line + ; (core_expr, ds_warns) <- initDs hsc_env this_mod type_env is_boot $ + dsExpr tc_expr -- Display any warnings -- Note: if -Werror is used, we don't signal an error here. ; doIfSet (not (isEmptyBag ds_warns)) - (printErrs warn_doc) + (printErrs (pprBagOfWarnings (mapBag mk_warn ds_warns))) -- Dump output ; dumpIfSet_dyn dflags Opt_D_dump_ds "Desugared" (pprCoreExpr core_expr) @@ -166,18 +156,12 @@ deSugarExpr hsc_env pcs this_mod rdr_env type_env tc_expr ; return core_expr } where - dflags = hsc_dflags hsc_env - hpt = hsc_HPT hsc_env - pte = eps_PTE (pcs_EPS pcs) - lookup n = lookupNameEnv type_env n `orElse` -- Look in the type env of the - -- current module first - lookupType hpt pte n `orElse` -- Then other modules - pprPanic "Desugar: lookup:" (ppr n) + dflags = hsc_dflags hsc_env + print_unqual = unQualInScope rdr_env mk_warn :: (SrcLoc,SDoc) -> (SrcLoc, Pretty.Doc) mk_warn (loc,sdoc) = addShortWarnLocLine loc print_unqual sdoc - print_unqual = unQualInScope rdr_env dsProgram all_binds rules fo_decls = dsMonoBinds auto_scc all_binds [] `thenDs` \ core_prs -> @@ -192,7 +176,7 @@ dsProgram all_binds rules fo_decls local_binders = mkVarSet (bindersOfBinds ds_binds) in - mapDs (dsRule local_binders) rules `thenDs` \ ds_rules -> + mappM (dsRule local_binders) rules `thenDs` \ ds_rules -> returnDs (ds_binds, ds_rules, ds_fords) where auto_scc | opt_SccProfilingOn = TopLevel @@ -214,9 +198,6 @@ ppr_ds_rules rules \begin{code} dsRule :: IdSet -> TypecheckedRuleDecl -> DsM (Id, CoreRule) -dsRule in_scope (IfaceRuleOut fun rule) -- Built-in rules come this way - = returnDs (fun, rule) - dsRule in_scope (HsRule name act vars lhs rhs loc) = putSrcLocDs loc $ ds_lhs all_vars lhs `thenDs` \ (fn, args) -> diff --git a/ghc/compiler/deSugar/DsArrows.lhs b/ghc/compiler/deSugar/DsArrows.lhs index b1714b81bb..c04c9ee766 100644 --- a/ghc/compiler/deSugar/DsArrows.lhs +++ b/ghc/compiler/deSugar/DsArrows.lhs @@ -201,7 +201,7 @@ matchEnvStack :: [Id] -- x1..xn -> CoreExpr -- e -> DsM CoreExpr matchEnvStack env_ids stack_ids body - = getUniqSupplyDs `thenDs` \ uniqs -> + = newUniqueSupply `thenDs` \ uniqs -> newSysLocalDs (mkTupleType env_ids) `thenDs` \ tup_var -> matchVarStack tup_var stack_ids (coreCaseTuple uniqs tup_var env_ids body) @@ -358,7 +358,7 @@ dsCmd ids local_vars env_ids stack res_ty (HsApp cmd arg) in dsfixCmd ids local_vars stack' res_ty cmd `thenDs` \ (core_cmd, free_vars, env_ids') -> - mapDs newSysLocalDs stack `thenDs` \ stack_ids -> + mappM newSysLocalDs stack `thenDs` \ stack_ids -> newSysLocalDs arg_ty `thenDs` \ arg_id -> -- push the argument expression onto the stack let @@ -392,7 +392,7 @@ dsCmd ids local_vars env_ids stack res_ty in dsfixCmd ids local_vars' stack' res_ty body `thenDs` \ (core_body, free_vars, env_ids') -> - mapDs newSysLocalDs stack `thenDs` \ stack_ids -> + mappM newSysLocalDs stack `thenDs` \ stack_ids -> -- the expression is built from the inside out, so the actions -- are presented in reverse order @@ -433,7 +433,7 @@ dsCmd ids local_vars env_ids stack res_ty (HsIf cond then_cmd else_cmd _loc) `thenDs` \ (core_then, fvs_then, then_ids) -> dsfixCmd ids local_vars stack res_ty else_cmd `thenDs` \ (core_else, fvs_else, else_ids) -> - mapDs newSysLocalDs stack `thenDs` \ stack_ids -> + mappM newSysLocalDs stack `thenDs` \ stack_ids -> dsLookupTyCon eitherTyConName `thenDs` \ either_con -> dsLookupDataCon leftDataConName `thenDs` \ left_con -> dsLookupDataCon rightDataConName `thenDs` \ right_con -> @@ -487,7 +487,7 @@ case bodies, containing the following fields: \begin{code} dsCmd ids local_vars env_ids stack res_ty (HsCase exp matches src_loc) = dsExpr exp `thenDs` \ core_exp -> - mapDs newSysLocalDs stack `thenDs` \ stack_ids -> + mappM newSysLocalDs stack `thenDs` \ stack_ids -> -- Extract and desugar the leaf commands in the case, building tuple -- expressions that will (after tagging) replace these leaves @@ -502,7 +502,7 @@ dsCmd ids local_vars env_ids stack res_ty (HsCase exp matches src_loc) envStackType leaf_ids stack, core_leaf) in - mapDs make_branch leaves `thenDs` \ branches -> + mappM make_branch leaves `thenDs` \ branches -> dsLookupTyCon eitherTyConName `thenDs` \ either_con -> dsLookupDataCon leftDataConName `thenDs` \ left_con -> dsLookupDataCon rightDataConName `thenDs` \ right_con -> @@ -536,7 +536,7 @@ dsCmd ids local_vars env_ids stack res_ty (HsCase exp matches src_loc) matchEnvStack env_ids stack_ids core_body `thenDs` \ core_matches -> returnDs(do_map_arrow ids in_ty sum_ty res_ty core_matches core_choices, - fvs_exp `unionVarSet` fvs_alts) + fvs_exp `unionVarSet` fvs_alts) -- A | ys |- c :: [ts] t -- ---------------------------------- @@ -551,7 +551,7 @@ dsCmd ids local_vars env_ids stack res_ty (HsLet binds body) in dsfixCmd ids local_vars' stack res_ty body `thenDs` \ (core_body, free_vars, env_ids') -> - mapDs newSysLocalDs stack `thenDs` \ stack_ids -> + mappM newSysLocalDs stack `thenDs` \ stack_ids -> -- build a new environment, plus the stack, using the let bindings dsLet binds (buildEnvStack env_ids' stack_ids) `thenDs` \ core_binds -> @@ -598,7 +598,7 @@ dsTrimCmdArg local_vars env_ids (HsCmdTop cmd stack cmd_ty ids) = mkCmdEnv ids `thenDs` \ meth_ids -> dsfixCmd meth_ids local_vars stack cmd_ty cmd `thenDs` \ (core_cmd, free_vars, env_ids') -> - mapDs newSysLocalDs stack `thenDs` \ stack_ids -> + mappM newSysLocalDs stack `thenDs` \ stack_ids -> matchEnvStack env_ids stack_ids (buildEnvStack env_ids' stack_ids) `thenDs` \ trim_code -> let @@ -751,7 +751,7 @@ dsCmdStmt ids local_vars env_ids out_ids (BindStmt pat cmd _loc) selectMatchVar pat `thenDs` \ pat_id -> newSysLocalDs env_ty2 `thenDs` \ env_id -> - getUniqSupplyDs `thenDs` \ uniqs -> + newUniqueSupply `thenDs` \ uniqs -> let after_c_ty = mkCorePairTy pat_ty env_ty2 out_ty = mkTupleType out_ids @@ -818,7 +818,7 @@ dsCmdStmt ids local_vars env_ids out_ids (RecStmt stmts later_ids rec_ids rhss) -- post_loop_fn = \((later_ids),(env2_ids)) -> (out_ids) - getUniqSupplyDs `thenDs` \ uniqs -> + newUniqueSupply `thenDs` \ uniqs -> newSysLocalDs env2_ty `thenDs` \ env2_id -> let later_ty = mkTupleType later_ids @@ -874,7 +874,7 @@ dsRecCmd ids local_vars stmts later_ids rec_ids rhss -- mk_pair_fn = \ (out_ids) -> ((later_ids),(rhss)) - mapDs dsExpr rhss `thenDs` \ core_rhss -> + mappM dsExpr rhss `thenDs` \ core_rhss -> let later_tuple = mkTupleExpr later_ids later_ty = mkTupleType later_ids diff --git a/ghc/compiler/deSugar/DsBinds.lhs b/ghc/compiler/deSugar/DsBinds.lhs index 97c844ed45..ff2403e6f4 100644 --- a/ghc/compiler/deSugar/DsBinds.lhs +++ b/ghc/compiler/deSugar/DsBinds.lhs @@ -83,7 +83,7 @@ dsMonoBinds auto_scc (PatMonoBind pat grhss locn) rest = putSrcLocDs locn $ dsGuarded grhss `thenDs` \ body_expr -> mkSelectorBinds pat body_expr `thenDs` \ sel_binds -> - mapDs (addAutoScc auto_scc) sel_binds `thenDs` \ sel_binds -> + mappM (addAutoScc auto_scc) sel_binds `thenDs` \ sel_binds -> returnDs (sel_binds ++ rest) -- Common special case: no type or dictionary abstraction @@ -134,7 +134,7 @@ dsMonoBinds auto_scc (AbsBinds all_tyvars dicts exports inlines binds) rest let dict_args = map Var dicts - mk_bind (tyvars, global, local) n -- locals !! n == local + mk_bind ((tyvars, global, local), n) -- locals !! n == local = -- Need to make fresh locals to bind in the selector, because -- some of the tyvars will be bound to voidTy newSysLocalsDs (map substitute local_tys) `thenDs` \ locals' -> @@ -148,7 +148,7 @@ dsMonoBinds auto_scc (AbsBinds all_tyvars dicts exports inlines binds) rest ty_args = map mk_ty_arg all_tyvars substitute = substTyWith all_tyvars ty_args in - zipWithDs mk_bind exports [0..] `thenDs` \ export_binds -> + mappM mk_bind (exports `zip` [0..]) `thenDs` \ export_binds -> -- don't scc (auto-)annotate the tuple itself. returnDs ((poly_tup_id, poly_tup_expr) : (export_binds ++ rest)) \end{code} diff --git a/ghc/compiler/deSugar/DsCCall.lhs b/ghc/compiler/deSugar/DsCCall.lhs index 71f3324adf..e643772323 100644 --- a/ghc/compiler/deSugar/DsCCall.lhs +++ b/ghc/compiler/deSugar/DsCCall.lhs @@ -14,6 +14,7 @@ module DsCCall #include "HsVersions.h" + import CoreSyn import DsMonad @@ -30,7 +31,7 @@ import TcType ( tcSplitTyConApp_maybe ) import Type ( Type, isUnLiftedType, mkFunTys, mkFunTy, tyVarsOfType, mkForAllTys, mkTyConApp, isPrimitiveType, splitTyConApp_maybe, - splitNewType_maybe, splitForAllTy_maybe, + splitRecNewType_maybe, splitForAllTy_maybe, isUnboxedTupleType ) @@ -62,6 +63,11 @@ import PrelNames ( Unique, hasKey, ioTyConKey, boolTyConKey, unitTyConKey, import VarSet ( varSetElems ) import Constants ( wORD_SIZE) import Outputable + +#ifdef DEBUG +import TypeRep +#endif + \end{code} Desugaring of @ccall@s consists of adding some state manipulation, @@ -109,7 +115,7 @@ dsCCall :: CLabelString -- C routine to invoke dsCCall lbl args may_gc result_ty = mapAndUnzipDs unboxArg args `thenDs` \ (unboxed_args, arg_wrappers) -> boxResult [] id Nothing result_ty `thenDs` \ (ccall_result_ty, res_wrapper) -> - getUniqueDs `thenDs` \ uniq -> + newUnique `thenDs` \ uniq -> let target = StaticTarget lbl the_fcall = CCall (CCallSpec target CCallConv may_gc) @@ -155,7 +161,7 @@ unboxArg arg = returnDs (arg, \body -> body) -- Recursive newtypes - | Just rep_ty <- splitNewType_maybe arg_ty + | Just rep_ty <- splitRecNewType_maybe arg_ty = unboxArg (mkCoerce2 rep_ty arg_ty arg) -- Booleans @@ -172,7 +178,8 @@ unboxArg arg -- Data types with a single constructor, which has a single, primitive-typed arg -- This deals with Int, Float etc; also Ptr, ForeignPtr | is_product_type && data_con_arity == 1 - = ASSERT(isUnLiftedType data_con_arg_ty1 ) -- Typechecker ensures this + = ASSERT2(isUnLiftedType data_con_arg_ty1, crudePprType arg_ty) + -- Typechecker ensures this newSysLocalDs arg_ty `thenDs` \ case_bndr -> newSysLocalDs data_con_arg_ty1 `thenDs` \ prim_arg -> returnDs (Var prim_arg, @@ -335,10 +342,10 @@ boxResult arg_ids augment mbTopCon result_ty -- The ccall returns a non-() value | isUnboxedTupleType prim_res_ty = let - (Just (_, ls@(prim_res_ty1:extras))) = splitTyConApp_maybe prim_res_ty + Just (_, ls) = splitTyConApp_maybe prim_res_ty arity = 1 + length ls in - mapDs newSysLocalDs ls `thenDs` \ args_ids@(result_id:as) -> + mappM newSysLocalDs ls `thenDs` \ args_ids@(result_id:as) -> newSysLocalDs realWorldStatePrimTy `thenDs` \ state_id -> let the_rhs = return_result (Var state_id) @@ -352,8 +359,7 @@ boxResult arg_ids augment mbTopCon result_ty in returnDs (ccall_res_ty, the_alt) | otherwise - = - newSysLocalDs prim_res_ty `thenDs` \ result_id -> + = newSysLocalDs prim_res_ty `thenDs` \ result_id -> newSysLocalDs realWorldStatePrimTy `thenDs` \ state_id -> let the_rhs = return_result (Var state_id) @@ -385,7 +391,7 @@ resultWrapper result_ty (LitAlt (mkMachInt 0),[],Var falseDataConId)]) -- Recursive newtypes - | Just rep_ty <- splitNewType_maybe result_ty + | Just rep_ty <- splitRecNewType_maybe result_ty = resultWrapper rep_ty `thenDs` \ (maybe_ty, wrapper) -> returnDs (maybe_ty, \e -> mkCoerce2 result_ty rep_ty (wrapper e)) diff --git a/ghc/compiler/deSugar/DsExpr.lhs b/ghc/compiler/deSugar/DsExpr.lhs index a26d5a752e..1e9c6e1cc6 100644 --- a/ghc/compiler/deSugar/DsExpr.lhs +++ b/ghc/compiler/deSugar/DsExpr.lhs @@ -13,7 +13,6 @@ import Match ( matchWrapper, matchSimply ) import MatchLit ( dsLit ) import DsBinds ( dsMonoBinds, AutoScc(..) ) import DsGRHSs ( dsGuarded ) -import DsCCall ( dsCCall ) import DsListComp ( dsListComp, dsPArrComp ) import DsUtils ( mkErrorAppDs, mkStringLit, mkConsExpr, mkNilExpr, mkCoreTupTy, selectMatchVar, @@ -346,7 +345,7 @@ dsExpr (ExplicitPArr ty xs) returnDs (mkApps (Var toP) [Type ty, coreList]) dsExpr (ExplicitTuple expr_list boxity) - = mapDs dsExpr expr_list `thenDs` \ core_exprs -> + = mappM dsExpr expr_list `thenDs` \ core_exprs -> returnDs (mkConApp (tupleCon boxity (length expr_list)) (map (Type . exprType) core_exprs ++ core_exprs)) @@ -434,8 +433,8 @@ dsExpr (RecordConOut data_con con_expr rbinds) in (if null labels - then mapDs unlabelled_bottom arg_tys - else mapDs mk_arg (zipEqual "dsExpr:RecordCon" arg_tys labels)) + then mappM unlabelled_bottom arg_tys + else mappM mk_arg (zipEqual "dsExpr:RecordCon" arg_tys labels)) `thenDs` \ con_args -> returnDs (mkApps con_expr' con_args) @@ -506,7 +505,7 @@ dsExpr expr@(RecordUpdOut record_expr record_in_ty record_out_ty rbinds) -- and the right hand sides with applications of the wrapper Id -- so that everything works when we are doing fancy unboxing on the -- constructor aguments. - mapDs mk_alt cons_to_upd `thenDs` \ alts -> + mappM mk_alt cons_to_upd `thenDs` \ alts -> matchWrapper RecUpd alts `thenDs` \ ([discrim_var], matching_code) -> returnDs (bindNonRec discrim_var record_expr' matching_code) diff --git a/ghc/compiler/deSugar/DsForeign.lhs b/ghc/compiler/deSugar/DsForeign.lhs index 22c8569aae..a832499181 100644 --- a/ghc/compiler/deSugar/DsForeign.lhs +++ b/ghc/compiler/deSugar/DsForeign.lhs @@ -9,6 +9,7 @@ Expanding out @foreign import@ and @foreign export@ declarations. module DsForeign ( dsForeigns ) where #include "HsVersions.h" +import TcRnMonad -- temp import CoreSyn @@ -76,8 +77,10 @@ dsForeigns fos where combine (ForeignStubs acc_h acc_c acc_hdrs acc_feb, acc_f) (ForeignImport id _ spec depr loc) - = dsFImport id spec `thenDs` \ (bs, h, c, mbhd) -> + = traceIf (text "fi start" <+> ppr id) `thenDs` \ _ -> + dsFImport id spec `thenDs` \ (bs, h, c, mbhd) -> warnDepr depr loc `thenDs` \ _ -> + traceIf (text "fi end" <+> ppr id) `thenDs` \ _ -> returnDs (ForeignStubs (h $$ acc_h) (c $$ acc_c) (addH mbhd acc_hdrs) @@ -234,8 +237,8 @@ dsFCall fn_id fcall no_hdrs topConDs `thenDs` \ topCon -> boxResult maybe_arg_ids augment topCon io_res_ty `thenDs` \ (ccall_result_ty, res_wrapper) -> - getUniqueDs `thenDs` \ ccall_uniq -> - getUniqueDs `thenDs` \ work_uniq -> + newUnique `thenDs` \ ccall_uniq -> + newUnique `thenDs` \ work_uniq -> let -- Build the worker worker_ty = mkForAllTys tvs (mkFunTys (map idType work_arg_ids) ccall_result_ty) @@ -290,7 +293,7 @@ dsFExport :: Id -- Either the exported Id, dsFExport fn_id ty ext_name cconv isDyn = let - (tvs,sans_foralls) = tcSplitForAllTys ty + (_tvs,sans_foralls) = tcSplitForAllTys ty (fe_arg_tys', orig_res_ty) = tcSplitFunTys sans_foralls -- We must use tcSplits here, because we want to see -- the (IO t) in the corner of the type! diff --git a/ghc/compiler/deSugar/DsGRHSs.lhs b/ghc/compiler/deSugar/DsGRHSs.lhs index 0aef3a6e4d..75c76d6209 100644 --- a/ghc/compiler/deSugar/DsGRHSs.lhs +++ b/ghc/compiler/deSugar/DsGRHSs.lhs @@ -52,7 +52,7 @@ dsGRHSs :: TypecheckedMatchContext -> [TypecheckedPat] -- These are to build a M -> DsM (Type, MatchResult) dsGRHSs kind pats (GRHSs grhss binds ty) - = mapDs (dsGRHS kind pats) grhss `thenDs` \ match_results -> + = mappM (dsGRHS kind pats) grhss `thenDs` \ match_results -> let match_result1 = foldr1 combineMatchResults match_results match_result2 = adjustMatchResultDs (dsLet binds) match_result1 diff --git a/ghc/compiler/deSugar/DsListComp.lhs b/ghc/compiler/deSugar/DsListComp.lhs index 9a77075d96..fc3a689773 100644 --- a/ghc/compiler/deSugar/DsListComp.lhs +++ b/ghc/compiler/deSugar/DsListComp.lhs @@ -11,7 +11,6 @@ module DsListComp ( dsListComp, dsPArrComp ) where import {-# SOURCE #-} DsExpr ( dsExpr, dsLet ) import BasicTypes ( Boxity(..) ) -import TyCon ( tyConName ) import HsSyn ( Pat(..), HsExpr(..), Stmt(..), HsMatchContext(..), HsStmtContext(..), collectHsBinders ) @@ -30,10 +29,10 @@ import Type ( mkTyVarTy, mkFunTys, mkFunTy, Type, splitTyConApp_maybe ) import TysPrim ( alphaTyVar ) import TysWiredIn ( nilDataCon, consDataCon, trueDataConId, falseDataConId, - unitDataConId, unitTy, mkListTy ) + unitDataConId, unitTy, mkListTy, parrTyCon ) import Match ( matchSimply ) import PrelNames ( foldrName, buildName, replicatePName, mapPName, - filterPName, zipPName, crossPName, parrTyConName ) + filterPName, zipPName, crossPName ) import PrelInfo ( pAT_ERROR_ID ) import SrcLoc ( noSrcLoc ) import Panic ( panic ) @@ -147,7 +146,7 @@ with the Unboxed variety. deListComp :: [TypecheckedStmt] -> CoreExpr -> DsM CoreExpr deListComp (ParStmt stmtss_w_bndrs : quals) list - = mapDs do_list_comp stmtss_w_bndrs `thenDs` \ exps -> + = mappM do_list_comp stmtss_w_bndrs `thenDs` \ exps -> mkZipBind qual_tys `thenDs` \ (zip_fn, zip_rhs) -> -- Deal with [e | pat <- zip l1 .. ln] in example above @@ -233,9 +232,9 @@ mkZipBind :: [Type] -> DsM (Id, CoreExpr) -- (a2:as'2) -> (a2,a2) : zip as'1 as'2)] mkZipBind elt_tys - = mapDs newSysLocalDs list_tys `thenDs` \ ass -> - mapDs newSysLocalDs elt_tys `thenDs` \ as' -> - mapDs newSysLocalDs list_tys `thenDs` \ as's -> + = mappM newSysLocalDs list_tys `thenDs` \ ass -> + mappM newSysLocalDs elt_tys `thenDs` \ as' -> + mappM newSysLocalDs list_tys `thenDs` \ as's -> newSysLocalDs zip_fn_ty `thenDs` \ zip_fn -> let inner_rhs = mkConsExpr ret_elt_ty @@ -473,7 +472,7 @@ deLambda ty p e = parrElemType :: CoreExpr -> Type parrElemType e = case splitTyConApp_maybe (exprType e) of - Just (tycon, [ty]) | tyConName tycon == parrTyConName -> ty + Just (tycon, [ty]) | tycon == parrTyCon -> ty _ -> panic "DsListComp.parrElemType: not a parallel array type" \end{code} diff --git a/ghc/compiler/deSugar/DsMeta.hs b/ghc/compiler/deSugar/DsMeta.hs index f92af145d5..ffb6b13b21 100644 --- a/ghc/compiler/deSugar/DsMeta.hs +++ b/ghc/compiler/deSugar/DsMeta.hs @@ -30,21 +30,18 @@ import HsSyn ( Pat(..), HsExpr(..), Stmt(..), HsLit(..), HsOverLit(..), Match(..), GRHSs(..), GRHS(..), HsBracket(..), HsStmtContext(ListComp,DoExpr), ArithSeqInfo(..), HsBinds(..), MonoBinds(..), HsConDetails(..), - TyClDecl(..), HsGroup(..), + TyClDecl(..), HsGroup(..), HsBang(..), HsReify(..), ReifyFlavour(..), - HsType(..), HsContext(..), HsPred(..), HsTyOp(..), + HsType(..), HsContext(..), HsPred(..), HsTyVarBndr(..), Sig(..), ForeignDecl(..), InstDecl(..), ConDecl(..), BangType(..), PendingSplice, splitHsInstDeclTy, placeHolderType, tyClDeclNames, collectHsBinders, collectPatBinders, collectPatsBinders, - hsTyVarName, hsConArgs, getBangType, - toHsType + hsTyVarName, hsConArgs ) -import PrelNames ( mETA_META_Name, rationalTyConName, negateName, - parrTyConName ) -import MkIface ( ifaceTyThing ) +import PrelNames ( mETA_META_Name, rationalTyConName, integerTyConName, negateName ) import Name ( Name, nameOccName, nameModule, getSrcLoc ) import OccName ( isDataOcc, isTvOcc, occNameUserString ) -- To avoid clashes with DsMeta.varName we must make a local alias for OccName.varName @@ -53,16 +50,16 @@ import OccName ( isDataOcc, isTvOcc, occNameUserString ) -- ws previously used in this file. import qualified OccName( varName, tcName ) -import Module ( Module, mkThPkgModule, moduleUserString ) +import Module ( Module, mkModule, moduleUserString ) import Id ( Id, idType ) -import Name ( mkKnownKeyExternalName ) +import Name ( mkExternalName ) import OccName ( mkOccFS ) import NameEnv import NameSet import Type ( Type, mkGenTyConApp ) -import TcType ( TyThing(..), tcTyConAppArgs ) -import TyCon ( DataConDetails(..) ) -import TysWiredIn ( stringTy ) +import TcType ( tcTyConAppArgs ) +import TyCon ( DataConDetails(..), tyConName ) +import TysWiredIn ( stringTy, parrTyCon ) import CoreSyn import CoreUtils ( exprType ) import SrcLoc ( noSrcLoc ) @@ -72,7 +69,7 @@ import Panic ( panic ) import Unique ( mkPreludeTyConUnique, mkPreludeMiscIdUnique ) import BasicTypes ( NewOrData(..), StrictnessMark(..), isBoxed ) import SrcLoc ( SrcLoc ) - +import Packages ( thPackage ) import Outputable import FastString ( mkFastString ) @@ -97,9 +94,12 @@ dsBracket brack splices ----------------------------------------------------------------------------- dsReify :: HsReify Id -> DsM CoreExpr +dsReify r = panic "dsReify" -- To be re-done + -- Returns a CoreExpr of type reifyType --> M.TypeQ -- reifyDecl --> M.DecQ -- reifyFixty --> Q M.Fix +{- dsReify (ReifyOut ReifyType name) = do { thing <- dsLookupGlobal name ; -- By deferring the lookup until now (rather than doing it @@ -118,7 +118,7 @@ dsReify r@(ReifyOut ReifyDecl name) Just (MkC d) -> return d Nothing -> pprPanic "dsReify" (ppr r) } - +-} {- -------------- Examples -------------------- [| \x -> x |] @@ -207,9 +207,9 @@ repTyClD decl = do x <- repTyClD' decl repTyClD' :: TyClDecl Name -> DsM (Maybe (SrcLoc, Core M.DecQ)) repTyClD' (TyData { tcdND = DataType, tcdCtxt = cxt, - tcdName = tc, tcdTyVars = tvs, - tcdCons = DataCons cons, tcdDerivs = mb_derivs, - tcdLoc = loc}) + tcdName = tc, tcdTyVars = tvs, + tcdCons = cons, tcdDerivs = mb_derivs, + tcdLoc = loc}) = do { tc1 <- lookupOcc tc ; -- See note [Binders and occurrences] dec <- addTyVarBinds tvs $ \bndrs -> do { cxt1 <- repContext cxt ; @@ -220,9 +220,9 @@ repTyClD' (TyData { tcdND = DataType, tcdCtxt = cxt, return $ Just (loc, dec) } repTyClD' (TyData { tcdND = NewType, tcdCtxt = cxt, - tcdName = tc, tcdTyVars = tvs, - tcdCons = DataCons [con], tcdDerivs = mb_derivs, - tcdLoc = loc}) + tcdName = tc, tcdTyVars = tvs, + tcdCons = [con], tcdDerivs = mb_derivs, + tcdLoc = loc}) = do { tc1 <- lookupOcc tc ; -- See note [Binders and occurrences] dec <- addTyVarBinds tvs $ \bndrs -> do { cxt1 <- repContext cxt ; @@ -242,7 +242,7 @@ repTyClD' (TySynonym { tcdName = tc, tcdTyVars = tvs, tcdSynRhs = ty, repTyClD' (ClassDecl { tcdCtxt = cxt, tcdName = cls, tcdTyVars = tvs, tcdFDs = [], -- We don't understand functional dependencies - tcdSigs = sigs, tcdMeths = mb_meth_binds, + tcdSigs = sigs, tcdMeths = meth_binds, tcdLoc = loc}) = do { cls1 <- lookupOcc cls ; -- See note [Binders and occurrences] dec <- addTyVarBinds tvs $ \bndrs -> do { @@ -252,11 +252,6 @@ repTyClD' (ClassDecl { tcdCtxt = cxt, tcdName = cls, decls1 <- coreList decQTyConName (sigs1 ++ binds1) ; repClass cxt1 cls1 (coreList' stringTy bndrs) decls1 } ; return $ Just (loc, dec) } - where - -- If the user quotes a class decl, it'll have default-method - -- bindings; but if we (reifyDecl C) where C is a class, we - -- won't be given the default methods (a definite infelicity). - meth_binds = mb_meth_binds `orElse` EmptyMonoBinds -- Un-handled cases repTyClD' d = do { addDsWarn (hang msg 4 (ppr d)) ; @@ -265,7 +260,7 @@ repTyClD' d = do { addDsWarn (hang msg 4 (ppr d)) ; where msg = ptext SLIT("Cannot desugar this Template Haskell declaration:") -repInstD' (InstDecl ty binds _ _ loc) +repInstD' (InstDecl ty binds _ loc) -- Ignore user pragmas for now = do { cxt1 <- repContext cxt ; inst_ty1 <- repPred (HsClassP cls tys) ; @@ -291,8 +286,8 @@ repBangTy (BangType str ty) = do MkC s <- rep2 strName [] MkC t <- repTy ty rep2 strictTypeName [s, t] where strName = case str of - NotMarkedStrict -> notStrictName - _ -> isStrictName + HsNoBang -> notStrictName + other -> isStrictName ------------------------------------------------------- -- Deriving clause @@ -326,9 +321,8 @@ rep_sigs' sigs = do { sigs1 <- mapM rep_sig sigs ; rep_sig :: Sig Name -> DsM [(SrcLoc, Core M.DecQ)] -- Singleton => Ok -- Empty => Too hard, signature ignored -rep_sig (ClassOpSig nm _ ty loc) = rep_proto nm ty loc -rep_sig (Sig nm ty loc) = rep_proto nm ty loc -rep_sig other = return [] +rep_sig (Sig nm ty loc) = rep_proto nm ty loc +rep_sig other = return [] rep_proto :: Name -> HsType Name -> SrcLoc -> DsM [(SrcLoc, Core M.DecQ)] rep_proto nm ty loc = do { nm1 <- lookupOcc nm ; @@ -411,14 +405,13 @@ repTy (HsListTy t) = do repTapp tcon t1 repTy (HsPArrTy t) = do t1 <- repTy t - tcon <- repTy (HsTyVar parrTyConName) + tcon <- repTy (HsTyVar (tyConName parrTyCon)) repTapp tcon t1 repTy (HsTupleTy tc tys) = do tys1 <- repTys tys tcon <- repTupleTyCon (length tys) repTapps tcon tys1 -repTy (HsOpTy ty1 HsArrow ty2) = repTy (HsFunTy ty1 ty2) -repTy (HsOpTy ty1 (HsTyOp n) ty2) = repTy ((HsTyVar n `HsAppTy` ty1) +repTy (HsOpTy ty1 n ty2) = repTy ((HsTyVar n `HsAppTy` ty1) `HsAppTy` ty2) repTy (HsParTy t) = repTy t repTy (HsNumTy i) = @@ -1129,18 +1122,16 @@ repListTyCon = rep2 listTName [] repLiteral :: HsLit -> DsM (Core M.Lit) repLiteral lit = do lit' <- case lit of - HsIntPrim i -> return $ HsInteger i - HsInt i -> return $ HsInteger i - HsFloatPrim r -> do rat_ty <- lookupType rationalTyConName - return $ HsRat r rat_ty - HsDoublePrim r -> do rat_ty <- lookupType rationalTyConName - return $ HsRat r rat_ty + HsIntPrim i -> mk_integer i + HsInt i -> mk_integer i + HsFloatPrim r -> mk_rational r + HsDoublePrim r -> mk_rational r _ -> return lit lit_expr <- dsLit lit' rep2 lit_name [lit_expr] where lit_name = case lit of - HsInteger _ -> integerLName + HsInteger _ _ -> integerLName HsInt _ -> integerLName HsIntPrim _ -> intPrimLName HsFloatPrim _ -> floatPrimLName @@ -1152,10 +1143,14 @@ repLiteral lit uh_oh = pprPanic "DsMeta.repLiteral: trying to represent exotic literal" (ppr lit) +mk_integer i = do integer_ty <- lookupType integerTyConName + return $ HsInteger i integer_ty +mk_rational r = do rat_ty <- lookupType rationalTyConName + return $ HsRat r rat_ty + repOverloadedLiteral :: HsOverLit -> DsM (Core M.Lit) -repOverloadedLiteral (HsIntegral i _) = repLiteral (HsInteger i) -repOverloadedLiteral (HsFractional f _) = do { rat_ty <- lookupType rationalTyConName ; - repLiteral (HsRat f rat_ty) } +repOverloadedLiteral (HsIntegral i _) = do { lit <- mk_integer i; repLiteral lit } +repOverloadedLiteral (HsFractional f _) = do { lit <- mk_rational f; repLiteral lit } -- The type Rational will be in the environment, becuase -- the smart constructor 'THSyntax.rationalL' uses it in its type, -- and rationalL is sucked in when any TH stuff is used @@ -1218,11 +1213,11 @@ coreVar id = MkC (Var id) -- 2) Make a "Name" -- 3) Add the name to knownKeyNames -templateHaskellNames :: NameSet +templateHaskellNames :: [Name] -- The names that are implicitly mentioned by ``bracket'' -- Should stay in sync with the import list of DsMeta -templateHaskellNames = mkNameSet [ +templateHaskellNames = [ returnQName, bindQName, sequenceQName, gensymName, liftName, -- Lit charLName, stringLName, integerLName, intPrimLName, @@ -1277,10 +1272,11 @@ tcQual = mk_known_key_name OccName.tcName thModule :: Module -- NB: the THSyntax module comes from the "haskell-src" package -thModule = mkThPkgModule mETA_META_Name +thModule = mkModule thPackage mETA_META_Name mk_known_key_name space str uniq - = mkKnownKeyExternalName thModule (mkOccFS space str) uniq + = mkExternalName uniq thModule (mkOccFS space str) + Nothing noSrcLoc returnQName = varQual FSLIT("returnQ") returnQIdKey bindQName = varQual FSLIT("bindQ") bindQIdKey @@ -1323,9 +1319,9 @@ conEName = varQual FSLIT("conE") conEIdKey litEName = varQual FSLIT("litE") litEIdKey appEName = varQual FSLIT("appE") appEIdKey infixEName = varQual FSLIT("infixE") infixEIdKey -infixAppName = varQual FSLIT("infixApp") infixAppIdKey -sectionLName = varQual FSLIT("sectionL") sectionLIdKey -sectionRName = varQual FSLIT("sectionR") sectionRIdKey +infixAppName = varQual FSLIT("infixApp") infixAppIdKey +sectionLName = varQual FSLIT("sectionL") sectionLIdKey +sectionRName = varQual FSLIT("sectionR") sectionRIdKey lamEName = varQual FSLIT("lamE") lamEIdKey tupEName = varQual FSLIT("tupE") tupEIdKey condEName = varQual FSLIT("condE") condEIdKey diff --git a/ghc/compiler/deSugar/DsMonad.lhs b/ghc/compiler/deSugar/DsMonad.lhs index 0889109049..c916626e8b 100644 --- a/ghc/compiler/deSugar/DsMonad.lhs +++ b/ghc/compiler/deSugar/DsMonad.lhs @@ -5,49 +5,52 @@ \begin{code} module DsMonad ( - DsM, - initDs, returnDs, thenDs, mapDs, listDs, fixDs, - mapAndUnzipDs, zipWithDs, foldlDs, - uniqSMtoDsM, - newTyVarsDs, cloneTyVarsDs, + DsM, mappM, + initDs, returnDs, thenDs, listDs, fixDs, mapAndUnzipDs, foldlDs, + + newTyVarsDs, duplicateLocalDs, newSysLocalDs, newSysLocalsDs, newUniqueId, newFailLocalDs, getSrcLocDs, putSrcLocDs, getModuleDs, - getUniqueDs, getUniquesDs, - UniqSupply, getUniqSupplyDs, + newUnique, + UniqSupply, newUniqueSupply, getDOptsDs, dsLookupGlobal, dsLookupGlobalId, dsLookupTyCon, dsLookupDataCon, DsMetaEnv, DsMetaVal(..), dsLookupMetaEnv, dsExtendMetaEnv, dsWarn, - DsWarnings, + DsWarning, DsMatchContext(..) ) where #include "HsVersions.h" import TcHsSyn ( TypecheckedPat, TypecheckedMatchContext, TypecheckedHsExpr ) -import HscTypes ( TyThing(..) ) +import TcRnMonad +import IfaceEnv ( tcIfaceGlobal ) +import HscTypes ( TyThing(..), TypeEnv, HscEnv, + IsBootInterface, + tyThingId, tyThingTyCon, tyThingDataCon ) import Bag ( emptyBag, snocBag, Bag ) import DataCon ( DataCon ) import TyCon ( TyCon ) import DataCon ( DataCon ) import Id ( mkSysLocal, setIdUnique, Id ) -import Module ( Module ) +import Module ( Module, ModuleName, ModuleEnv ) import Var ( TyVar, setTyVarUnique ) import Outputable import SrcLoc ( noSrcLoc, SrcLoc ) import Type ( Type ) -import UniqSupply ( initUs_, getUniqueUs, getUniquesUs, thenUs, returnUs, - fixUs, UniqSM, UniqSupply, getUs ) -import Unique ( Unique ) +import UniqSupply ( UniqSupply, uniqsFromSupply ) import Name ( Name, nameOccName ) import NameEnv import OccName ( occNameFS ) import CmdLineOpts ( DynFlags ) +import DATA_IOREF ( newIORef, readIORef ) + infixr 9 `thenDs` \end{code} @@ -55,17 +58,29 @@ Now the mondo monad magic (yes, @DsM@ is a silly name)---carry around a @UniqueSupply@ and some annotations, which presumably include source-file location information: \begin{code} -newtype DsM result - = DsM (DsEnv -> DsWarnings -> UniqSM (result, DsWarnings)) +type DsM result = TcRnIf DsGblEnv DsLclEnv result -unDsM (DsM x) = x +-- Compatibility functions +fixDs = fixM +thenDs = thenM +returnDs = returnM +listDs = sequenceM +foldlDs = foldlM +mapAndUnzipDs = mapAndUnzipM -data DsEnv = DsEnv { - ds_dflags :: DynFlags, - ds_globals :: Name -> TyThing, -- Lookup well-known Ids + +type DsWarning = (SrcLoc, SDoc) + +data DsGblEnv = DsGblEnv { + ds_mod :: Module, -- For SCC profiling + ds_warns :: IORef (Bag DsWarning), -- Warning messages + ds_if_env :: IfGblEnv -- Used for looking up global, + -- possibly-imported things + } + +data DsLclEnv = DsLclEnv { ds_meta :: DsMetaEnv, -- Template Haskell bindings - ds_loc :: SrcLoc, -- to put in pattern-matching error msgs - ds_mod :: Module -- module: for SCC profiling + ds_loc :: SrcLoc -- to put in pattern-matching error msgs } -- Inside [| |] brackets, the desugarer looks @@ -80,81 +95,29 @@ data DsMetaVal | Splice TypecheckedHsExpr -- These bindings are introduced by -- the PendingSplices on a HsBracketOut -instance Monad DsM where - return = returnDs - (>>=) = thenDs - -type DsWarnings = Bag DsWarning -- The desugarer reports matches which are - -- completely shadowed or incomplete patterns -type DsWarning = (SrcLoc, SDoc) - -{-# INLINE thenDs #-} -{-# INLINE returnDs #-} - -- initDs returns the UniqSupply out the end (not just the result) -initDs :: DynFlags - -> UniqSupply - -> (Name -> TyThing) - -> Module -- module name: for profiling +initDs :: HscEnv + -> Module -> TypeEnv + -> ModuleEnv (ModuleName,IsBootInterface) -> DsM a - -> (a, DsWarnings) - -initDs dflags init_us lookup mod (DsM action) - = initUs_ init_us (action ds_env emptyBag) - where - ds_env = DsEnv { ds_dflags = dflags, ds_globals = lookup, - ds_loc = noSrcLoc, ds_mod = mod, - ds_meta = emptyNameEnv } - -thenDs :: DsM a -> (a -> DsM b) -> DsM b - -thenDs (DsM m1) m2 = DsM( \ env warns -> - m1 env warns `thenUs` \ (result, warns1) -> - unDsM (m2 result) env warns1) - -returnDs :: a -> DsM a -returnDs result = DsM (\ env warns -> returnUs (result, warns)) - -fixDs :: (a -> DsM a) -> DsM a -fixDs f = DsM (\env warns -> fixUs (\ ~(a, _warns') -> unDsM (f a) env warns)) - -listDs :: [DsM a] -> DsM [a] -listDs [] = returnDs [] -listDs (x:xs) - = x `thenDs` \ r -> - listDs xs `thenDs` \ rs -> - returnDs (r:rs) - -mapDs :: (a -> DsM b) -> [a] -> DsM [b] - -mapDs f [] = returnDs [] -mapDs f (x:xs) - = f x `thenDs` \ r -> - mapDs f xs `thenDs` \ rs -> - returnDs (r:rs) - -foldlDs :: (a -> b -> DsM a) -> a -> [b] -> DsM a - -foldlDs k z [] = returnDs z -foldlDs k z (x:xs) = k z x `thenDs` \ r -> - foldlDs k r xs - -mapAndUnzipDs :: (a -> DsM (b, c)) -> [a] -> DsM ([b], [c]) - -mapAndUnzipDs f [] = returnDs ([], []) -mapAndUnzipDs f (x:xs) - = f x `thenDs` \ (r1, r2) -> - mapAndUnzipDs f xs `thenDs` \ (rs1, rs2) -> - returnDs (r1:rs1, r2:rs2) - -zipWithDs :: (a -> b -> DsM c) -> [a] -> [b] -> DsM [c] - -zipWithDs f [] ys = returnDs [] -zipWithDs f (x:xs) (y:ys) - = f x y `thenDs` \ r -> - zipWithDs f xs ys `thenDs` \ rs -> - returnDs (r:rs) + -> IO (a, Bag DsWarning) + +initDs hsc_env mod type_env is_boot thing_inside + = do { warn_var <- newIORef emptyBag + ; let { if_env = IfGblEnv { if_rec_types = Just (mod, return type_env), + if_is_boot = is_boot } + ; gbl_env = DsGblEnv { ds_mod = mod, + ds_if_env = if_env, + ds_warns = warn_var } + ; lcl_env = DsLclEnv { ds_meta = emptyNameEnv, + ds_loc = noSrcLoc } } + + ; res <- initTcRnIf 'd' hsc_env gbl_env lcl_env thing_inside + + ; warns <- readIORef warn_var + ; return (res, warns) + } \end{code} And all this mysterious stuff is so we can occasionally reach out and @@ -163,61 +126,35 @@ functions are defined with it. The difference in name-strings makes it easier to read debugging output. \begin{code} -uniqSMtoDsM :: UniqSM a -> DsM a -uniqSMtoDsM u_action = DsM(\ env warns -> - u_action `thenUs` \ res -> - returnUs (res, warns)) - - -getUniqueDs :: DsM Unique -getUniqueDs = DsM (\ env warns -> - getUniqueUs `thenUs` \ uniq -> - returnUs (uniq, warns)) - -getUniquesDs :: DsM [Unique] -getUniquesDs = DsM(\ env warns -> - getUniquesUs `thenUs` \ uniqs -> - returnUs (uniqs, warns)) - -getUniqSupplyDs :: DsM UniqSupply -getUniqSupplyDs = DsM(\ env warns -> - getUs `thenUs` \ uniqs -> - returnUs (uniqs, warns)) - -- Make a new Id with the same print name, but different type, and new unique newUniqueId :: Name -> Type -> DsM Id newUniqueId id ty - = getUniqueDs `thenDs` \ uniq -> + = newUnique `thenDs` \ uniq -> returnDs (mkSysLocal (occNameFS (nameOccName id)) uniq ty) duplicateLocalDs :: Id -> DsM Id duplicateLocalDs old_local - = getUniqueDs `thenDs` \ uniq -> + = newUnique `thenDs` \ uniq -> returnDs (setIdUnique old_local uniq) newSysLocalDs, newFailLocalDs :: Type -> DsM Id newSysLocalDs ty - = getUniqueDs `thenDs` \ uniq -> + = newUnique `thenDs` \ uniq -> returnDs (mkSysLocal FSLIT("ds") uniq ty) -newSysLocalsDs tys = mapDs newSysLocalDs tys +newSysLocalsDs tys = mappM newSysLocalDs tys newFailLocalDs ty - = getUniqueDs `thenDs` \ uniq -> + = newUnique `thenDs` \ uniq -> returnDs (mkSysLocal FSLIT("fail") uniq ty) -- The UserLocal bit just helps make the code a little clearer \end{code} \begin{code} -cloneTyVarsDs :: [TyVar] -> DsM [TyVar] -cloneTyVarsDs tyvars - = getUniquesDs `thenDs` \ uniqs -> - returnDs (zipWith setTyVarUnique tyvars uniqs) - newTyVarsDs :: [TyVar] -> DsM [TyVar] newTyVarsDs tyvar_tmpls - = getUniquesDs `thenDs` \ uniqs -> - returnDs (zipWith setTyVarUnique tyvar_tmpls uniqs) + = newUniqueSupply `thenDs` \ uniqs -> + returnDs (zipWith setTyVarUnique tyvar_tmpls (uniqsFromSupply uniqs)) \end{code} We can also reach out and either set/grab location information from @@ -225,56 +162,52 @@ the @SrcLoc@ being carried around. \begin{code} getDOptsDs :: DsM DynFlags -getDOptsDs = DsM(\ env warns -> returnUs (ds_dflags env, warns)) +getDOptsDs = getDOpts getModuleDs :: DsM Module -getModuleDs = DsM(\ env warns -> returnUs (ds_mod env, warns)) +getModuleDs = do { env <- getGblEnv; return (ds_mod env) } getSrcLocDs :: DsM SrcLoc -getSrcLocDs = DsM(\ env warns -> returnUs (ds_loc env, warns)) +getSrcLocDs = do { env <- getLclEnv; return (ds_loc env) } putSrcLocDs :: SrcLoc -> DsM a -> DsM a -putSrcLocDs new_loc (DsM expr) = DsM(\ env warns -> - expr (env { ds_loc = new_loc }) warns) +putSrcLocDs new_loc thing_inside = updLclEnv (\ env -> env {ds_loc = new_loc}) thing_inside dsWarn :: DsWarning -> DsM () -dsWarn warn = DsM(\ env warns -> returnUs ((), warns `snocBag` warn)) +dsWarn warn = do { env <- getGblEnv; updMutVar (ds_warns env) (`snocBag` warn) } \end{code} \begin{code} dsLookupGlobal :: Name -> DsM TyThing +-- Very like TcEnv.tcLookupGlobal dsLookupGlobal name - = DsM(\ env warns -> returnUs (ds_globals env name, warns)) + = do { env <- getGblEnv + ; setEnvs (ds_if_env env, ()) + (tcIfaceGlobal name) } dsLookupGlobalId :: Name -> DsM Id dsLookupGlobalId name = dsLookupGlobal name `thenDs` \ thing -> - returnDs $ case thing of - AnId id -> id - other -> pprPanic "dsLookupGlobalId" (ppr name) + returnDs (tyThingId thing) dsLookupTyCon :: Name -> DsM TyCon dsLookupTyCon name = dsLookupGlobal name `thenDs` \ thing -> - returnDs $ case thing of - ATyCon tc -> tc - other -> pprPanic "dsLookupTyCon" (ppr name) + returnDs (tyThingTyCon thing) dsLookupDataCon :: Name -> DsM DataCon dsLookupDataCon name = dsLookupGlobal name `thenDs` \ thing -> - returnDs $ case thing of - ADataCon dc -> dc - other -> pprPanic "dsLookupDataCon" (ppr name) + returnDs (tyThingDataCon thing) \end{code} \begin{code} dsLookupMetaEnv :: Name -> DsM (Maybe DsMetaVal) -dsLookupMetaEnv name = DsM(\ env warns -> returnUs (lookupNameEnv (ds_meta env) name, warns)) +dsLookupMetaEnv name = do { env <- getLclEnv; return (lookupNameEnv (ds_meta env) name) } dsExtendMetaEnv :: DsMetaEnv -> DsM a -> DsM a -dsExtendMetaEnv menv (DsM m) - = DsM (\ env warns -> m (env { ds_meta = ds_meta env `plusNameEnv` menv }) warns) +dsExtendMetaEnv menv thing_inside + = updLclEnv (\env -> env { ds_meta = ds_meta env `plusNameEnv` menv }) thing_inside \end{code} diff --git a/ghc/compiler/deSugar/DsUtils.lhs b/ghc/compiler/deSugar/DsUtils.lhs index d7b55f5ad3..e7f88fe690 100644 --- a/ghc/compiler/deSugar/DsUtils.lhs +++ b/ghc/compiler/deSugar/DsUtils.lhs @@ -58,15 +58,15 @@ import TysWiredIn ( nilDataCon, consDataCon, tupleCon, mkTupleTy, unitDataConId, unitTy, charTy, charDataCon, - intTy, intDataCon, smallIntegerDataCon, + intTy, intDataCon, floatDataCon, doubleDataCon, stringTy, isPArrFakeCon ) import BasicTypes ( Boxity(..) ) import UniqSet ( mkUniqSet, minusUniqSet, isEmptyUniqSet, UniqSet ) -import UniqSupply ( splitUniqSupply, uniqFromSupply ) +import UniqSupply ( splitUniqSupply, uniqFromSupply, uniqsFromSupply ) import PrelNames ( unpackCStringName, unpackCStringUtf8Name, - plusIntegerName, timesIntegerName, + plusIntegerName, timesIntegerName, smallIntegerDataConName, lengthPName, indexPName ) import Outputable import UnicodeUtil ( intsToUtf8, stringToUtf8 ) @@ -134,13 +134,13 @@ tidyNPat lit lit_ty default_pat | otherwise = default_pat where - mk_int (HsInteger i) = HsIntPrim i + mk_int (HsInteger i _) = HsIntPrim i - mk_float (HsInteger i) = HsFloatPrim (fromInteger i) - mk_float (HsRat f _) = HsFloatPrim f + mk_float (HsInteger i _) = HsFloatPrim (fromInteger i) + mk_float (HsRat f _) = HsFloatPrim f - mk_double (HsInteger i) = HsDoublePrim (fromInteger i) - mk_double (HsRat f _) = HsDoublePrim f + mk_double (HsInteger i _) = HsDoublePrim (fromInteger i) + mk_double (HsRat f _) = HsDoublePrim f \end{code} @@ -287,7 +287,7 @@ mkCoPrimCaseMatchResult var match_alts = MatchResult CanFail mk_case where mk_case fail - = mapDs (mk_alt fail) match_alts `thenDs` \ alts -> + = mappM (mk_alt fail) match_alts `thenDs` \ alts -> returnDs (Case (Var var) var ((DEFAULT, [], fail) : alts)) mk_alt fail (lit, MatchResult _ body_fn) = body_fn fail `thenDs` \ body -> @@ -328,13 +328,13 @@ mkCoAlgCaseMatchResult var match_alts = CanFail wild_var = mkWildId (idType var) - mk_case fail = mapDs (mk_alt fail) match_alts `thenDs` \ alts -> + mk_case fail = mappM (mk_alt fail) match_alts `thenDs` \ alts -> returnDs (Case (Var var) wild_var (mk_default fail ++ alts)) mk_alt fail (con, args, MatchResult _ body_fn) = body_fn fail `thenDs` \ body -> - getUniquesDs `thenDs` \ us -> - returnDs (mkReboxingAlt us con args body) + newUniqueSupply `thenDs` \ us -> + returnDs (mkReboxingAlt (uniqsFromSupply us) con args body) mk_default fail | exhaustive_case = [] | otherwise = [(DEFAULT, [], fail)] @@ -387,7 +387,7 @@ mkCoAlgCaseMatchResult var match_alts unboxAlt = newSysLocalDs intPrimTy `thenDs` \l -> dsLookupGlobalId indexPName `thenDs` \indexP -> - mapDs (mkAlt indexP) match_alts `thenDs` \alts -> + mappM (mkAlt indexP) match_alts `thenDs` \alts -> returnDs (DataAlt intDataCon, [l], (Case (Var l) wild (dft : alts))) where wild = mkWildId intPrimTy @@ -450,7 +450,8 @@ mkCharExpr c = mkConApp charDataCon [mkLit (MachChar c)] mkIntegerExpr i | inIntRange i -- Small enough, so start from an Int - = returnDs (mkSmallIntegerLit i) + = dsLookupDataCon smallIntegerDataConName `thenDs` \ integer_dc -> + returnDs (mkSmallIntegerLit integer_dc i) -- Special case for integral literals with a large magnitude: -- They are transformed into an expression involving only smaller @@ -458,25 +459,27 @@ mkIntegerExpr i | otherwise -- Big, so start from a string = dsLookupGlobalId plusIntegerName `thenDs` \ plus_id -> - dsLookupGlobalId timesIntegerName `thenDs` \ times_id -> + dsLookupGlobalId timesIntegerName `thenDs` \ times_id -> + dsLookupDataCon smallIntegerDataConName `thenDs` \ integer_dc -> let + lit i = mkSmallIntegerLit integer_dc i plus a b = Var plus_id `App` a `App` b times a b = Var times_id `App` a `App` b -- Transform i into (x1 + (x2 + (x3 + (...) * b) * b) * b) with abs xi <= b horner :: Integer -> Integer -> CoreExpr horner b i | abs q <= 1 = if r == 0 || r == i - then mkSmallIntegerLit i - else mkSmallIntegerLit r `plus` mkSmallIntegerLit (i-r) - | r == 0 = horner b q `times` mkSmallIntegerLit b - | otherwise = mkSmallIntegerLit r `plus` (horner b q `times` mkSmallIntegerLit b) + then lit i + else lit r `plus` lit (i-r) + | r == 0 = horner b q `times` lit b + | otherwise = lit r `plus` (horner b q `times` lit b) where (q,r) = i `quotRem` b in returnDs (horner tARGET_MAX_INT i) -mkSmallIntegerLit i = mkConApp smallIntegerDataCon [mkIntLit i] +mkSmallIntegerLit small_integer_data_con i = mkConApp small_integer_data_con [mkIntLit i] mkStringLit str = mkStringLitFS (mkFastString str) @@ -547,7 +550,7 @@ mkSelectorBinds pat val_expr -- This does not matter after desugaring, but there's a subtle -- issue with implicit parameters. Consider -- (x,y) = ?i - -- Then, ?i is given type {?i :: Int}, a SourceType, which is opaque + -- Then, ?i is given type {?i :: Int}, a PredType, which is opaque -- to the desugarer. (Why opaque? Because newtypes have to be. Why -- does it get that type? So that when we abstract over it we get the -- right top-level type (?i::Int) => ...) @@ -561,7 +564,7 @@ mkSelectorBinds pat val_expr mkErrorAppDs iRREFUT_PAT_ERROR_ID unitTy (showSDoc (ppr pat)) `thenDs` \ err_expr -> newSysLocalDs unitTy `thenDs` \ err_var -> - mapDs (mk_bind val_var err_var) binders `thenDs` \ binds -> + mappM (mk_bind val_var err_var) binders `thenDs` \ binds -> returnDs ( (val_var, val_expr) : (err_var, err_expr) : binds ) diff --git a/ghc/compiler/deSugar/Match.lhs b/ghc/compiler/deSugar/Match.lhs index 282ba80464..88868e6b1c 100644 --- a/ghc/compiler/deSugar/Match.lhs +++ b/ghc/compiler/deSugar/Match.lhs @@ -266,11 +266,11 @@ corresponds roughly to @matchVarCon@. \begin{code} match vars@(v:vs) eqns_info - = mapDs (tidyEqnInfo v) eqns_info `thenDs` \ tidy_eqns_info -> + = mappM (tidyEqnInfo v) eqns_info `thenDs` \ tidy_eqns_info -> let tidy_eqns_blks = unmix_eqns tidy_eqns_info in - mapDs (matchEqnBlock vars) tidy_eqns_blks `thenDs` \ match_results -> + mappM (matchEqnBlock vars) tidy_eqns_blks `thenDs` \ match_results -> returnDs (foldr1 combineMatchResults match_results) where unmix_eqns [] = [] @@ -712,7 +712,7 @@ matchWrapper ctxt matches EqnInfo _ _ arg_pats _ : _ = eqns_info error_string = matchContextErrString ctxt in - mapDs selectMatchVar arg_pats `thenDs` \ new_vars -> + mappM selectMatchVar arg_pats `thenDs` \ new_vars -> match_fun dflags new_vars eqns_info `thenDs` \ match_result -> mkErrorAppDs pAT_ERROR_ID result_ty error_string `thenDs` \ fail_expr -> diff --git a/ghc/compiler/deSugar/MatchCon.lhs b/ghc/compiler/deSugar/MatchCon.lhs index 141f6a7e3d..a874218982 100644 --- a/ghc/compiler/deSugar/MatchCon.lhs +++ b/ghc/compiler/deSugar/MatchCon.lhs @@ -86,7 +86,7 @@ matchConFamily (var:vars) eqns_info get_uniq (EqnInfo _ _ (ConPatOut data_con _ _ _ _ : _) _) = getUnique data_con in -- Now make a case alternative out of each group - mapDs (match_con vars) eqn_groups `thenDs` \ alts -> + mappM (match_con vars) eqn_groups `thenDs` \ alts -> returnDs (mkCoAlgCaseMatchResult var alts) \end{code} @@ -99,7 +99,7 @@ Wadler's chapter in SLPJ. match_con vars (eqn1@(EqnInfo _ _ (ConPatOut data_con (PrefixCon arg_pats) _ ex_tvs ex_dicts : _) _) : other_eqns) = -- Make new vars for the con arguments; avoid new locals where possible - mapDs selectMatchVar arg_pats `thenDs` \ arg_vars -> + mappM selectMatchVar arg_pats `thenDs` \ arg_vars -> -- Now do the business to make the alt for _this_ ConPat ... match (arg_vars ++ vars) diff --git a/ghc/compiler/deSugar/MatchLit.lhs b/ghc/compiler/deSugar/MatchLit.lhs index 2be6e259d6..e260e0cd58 100644 --- a/ghc/compiler/deSugar/MatchLit.lhs +++ b/ghc/compiler/deSugar/MatchLit.lhs @@ -19,14 +19,14 @@ import TcHsSyn ( TypecheckedPat ) import Id ( Id ) import CoreSyn import TyCon ( tyConDataCons ) -import TcType ( tcSplitTyConApp, isIntegerTy ) - +import TcType ( tcSplitTyConApp, isIntegerTy ) import PrelNames ( ratioTyConKey ) import Unique ( hasKey ) import Literal ( mkMachInt, Literal(..) ) import Maybes ( catMaybes ) import Panic ( panic, assertPanic ) import Ratio ( numerator, denominator ) +import Outputable \end{code} %************************************************************************ @@ -56,7 +56,7 @@ dsLit (HsChar c) = returnDs (mkCharExpr c) dsLit (HsCharPrim c) = returnDs (mkLit (MachChar c)) dsLit (HsString str) = mkStringLitFS str dsLit (HsStringPrim s) = returnDs (mkLit (MachStr s)) -dsLit (HsInteger i) = mkIntegerExpr i +dsLit (HsInteger i _) = mkIntegerExpr i dsLit (HsInt i) = returnDs (mkIntExpr i) dsLit (HsIntPrim i) = returnDs (mkIntLit i) dsLit (HsFloatPrim f) = returnDs (mkLit (MachFloat f)) diff --git a/ghc/compiler/ghci/ByteCodeAsm.lhs b/ghc/compiler/ghci/ByteCodeAsm.lhs index f0678402ec..928d5e3fdd 100644 --- a/ghc/compiler/ghci/ByteCodeAsm.lhs +++ b/ghc/compiler/ghci/ByteCodeAsm.lhs @@ -28,18 +28,18 @@ import TyCon ( TyCon ) import PrimOp ( PrimOp ) import PrimRep ( PrimRep(..), isFollowableRep, is64BitRep ) import Constants ( wORD_SIZE ) -import FastString ( FastString(..), unpackFS ) +import FastString ( FastString(..) ) import SMRep ( StgWord ) import FiniteMap import Outputable -import Control.Monad ( foldM, zipWithM ) -import Control.Monad.ST ( ST, runST ) +import Control.Monad ( foldM ) +import Control.Monad.ST ( runST ) import GHC.Word ( Word(..) ) import Data.Array.MArray import Data.Array.Unboxed ( listArray ) -import Data.Array.Base ( STUArray, UArray(..), unsafeWrite ) +import Data.Array.Base ( UArray(..) ) import Data.Array.ST ( castSTUArray ) import Foreign ( Word16, free ) import Data.Int ( Int64 ) diff --git a/ghc/compiler/ghci/InteractiveUI.hs b/ghc/compiler/ghci/InteractiveUI.hs index 6d1aa58f47..49a5b1cbac 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.160 2003/09/23 14:32:58 simonmar Exp $ +-- $Id: InteractiveUI.hs,v 1.161 2003/10/09 11:58:53 simonpj Exp $ -- -- GHC Interactive User Interface -- @@ -19,7 +19,7 @@ import CompManager import HscTypes ( TyThing(..), HomeModInfo(hm_linkable), HomePackageTable, isObjectLinkable, GhciMode(..) ) import HsSyn ( TyClDecl(..), ConDecl(..), Sig(..) ) -import MkIface ( ifaceTyThing ) +import IfaceSyn ( IfaceDecl( ifName ) ) import DriverFlags import DriverState import DriverUtil ( remove_spaces ) @@ -159,20 +159,20 @@ interactiveUI :: [FilePath] -> Maybe String -> IO () interactiveUI srcs maybe_expr = do dflags <- getDynFlags - cmstate <- cmInit Interactive; + cmstate <- cmInit Interactive dflags; hFlush stdout hSetBuffering stdout NoBuffering -- Initialise buffering for the *interpreted* I/O system - cmstate <- initInterpBuffering cmstate dflags + initInterpBuffering cmstate -- We don't want the cmd line to buffer any input that might be -- intended for the program, so unbuffer stdin. hSetBuffering stdin NoBuffering -- initial context is just the Prelude - cmstate <- cmSetContext cmstate dflags [] ["Prelude"] + cmstate <- cmSetContext cmstate [] ["Prelude"] #if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS Readline.initialize @@ -381,10 +381,11 @@ runStmt stmt | otherwise = do st <- getGHCiState dflags <- io getDynFlags - let dflags' = dopt_unset dflags Opt_WarnUnusedBinds + let cm_state' = cmSetDFlags (cmstate st) + (dopt_unset dflags Opt_WarnUnusedBinds) (new_cmstate, result) <- io $ withProgName (progname st) $ withArgs (args st) $ - cmRunStmt (cmstate st) dflags' stmt + cmRunStmt cm_state' stmt setGHCiState st{cmstate = new_cmstate} case result of CmRunFailed -> return [] @@ -438,22 +439,22 @@ no_buf_cmd = "IO.hSetBuffering IO.stdout IO.NoBuffering" ++ " Prelude.>> IO.hSetBuffering IO.stderr IO.NoBuffering" flush_cmd = "IO.hFlush IO.stdout Prelude.>> IO.hFlush IO.stderr" -initInterpBuffering :: CmState -> DynFlags -> IO CmState -initInterpBuffering cmstate dflags - = do (cmstate, maybe_hval) <- cmCompileExpr cmstate dflags no_buf_cmd +initInterpBuffering :: CmState -> IO () +initInterpBuffering cmstate + = do maybe_hval <- cmCompileExpr cmstate no_buf_cmd case maybe_hval of Just hval -> writeIORef turn_off_buffering (unsafeCoerce# hval :: IO ()) other -> panic "interactiveUI:setBuffering" - (cmstate, maybe_hval) <- cmCompileExpr cmstate dflags flush_cmd + maybe_hval <- cmCompileExpr cmstate flush_cmd case maybe_hval of Just hval -> writeIORef flush_interp (unsafeCoerce# hval :: IO ()) _ -> panic "interactiveUI:flush" turnOffBuffering -- Turn it off right now - return cmstate + return () flushInterpBuffers :: GHCi () @@ -477,11 +478,10 @@ info "" = throwDyn (CmdLineError "syntax: `:i <thing-you-want-info-about>'") info s = do let names = words s init_cms <- getCmState - dflags <- io getDynFlags let infoThings cms [] = return cms infoThings cms (name:names) = do - (cms, stuff) <- io (cmInfoThing cms dflags name) + stuff <- io (cmInfoThing cms name) io (putStrLn (showSDocForUser unqual ( vcat (intersperse (text "") (map showThing stuff)))) ) @@ -489,18 +489,21 @@ info s = do unqual = cmGetPrintUnqual init_cms - showThing (ty_thing, fixity) - = vcat [ text "-- " <> showTyThing ty_thing, - showFixity fixity (getName ty_thing), - ppr (ifaceTyThing True{-omit prags-} ty_thing) ] + showThing (decl, fixity) + = vcat [ text "-- " <> showTyThing decl, + showFixity fixity (ifName decl), + showTyThing decl ] showFixity fix name | fix == defaultFixity = empty | otherwise = ppr fix <+> - (if isSymOcc (nameOccName name) + (if isSymOcc name then ppr name else char '`' <> ppr name <> char '`') + showTyThing decl = ppr decl + +{- showTyThing (AClass cl) = hcat [ppr cl, text " is a class", showSrcLoc (className cl)] showTyThing (ADataCon dc) @@ -526,22 +529,22 @@ info s = do | otherwise = empty where loc = nameSrcLoc name +-} - cms <- infoThings init_cms names - setCmState cms + infoThings init_cms names return () addModule :: [FilePath] -> GHCi () addModule files = do state <- getGHCiState - dflags <- io (getDynFlags) io (revertCAFs) -- always revert CAFs on load/add. files <- mapM expandPath files let new_targets = files ++ targets state - graph <- io (cmDepAnal (cmstate state) dflags new_targets) - (cmstate1, ok, mods) <- io (cmLoadModules (cmstate state) dflags graph) + graph <- io (cmDepAnal (cmstate state) new_targets) + (cmstate1, ok, mods) <- io (cmLoadModules (cmstate state) graph) setGHCiState state{ cmstate = cmstate1, targets = new_targets } setContextAfterLoad mods + dflags <- io getDynFlags modulesLoadedMsg ok mods dflags changeDirectory :: String -> GHCi () @@ -550,8 +553,7 @@ changeDirectory dir = do when (targets state /= []) $ io $ putStr "Warning: changing directory causes all loaded modules to be unloaded, \n\ \because the search path has changed.\n" - dflags <- io getDynFlags - cmstate1 <- io (cmUnload (cmstate state) dflags) + cmstate1 <- io (cmUnload (cmstate state)) setGHCiState state{ cmstate = cmstate1, targets = [] } setContextAfterLoad [] dir <- expandPath dir @@ -575,9 +577,7 @@ defineMacro s = do -- compile the expression cms <- getCmState - dflags <- io getDynFlags - (new_cmstate, maybe_hv) <- io (cmCompileExpr cms dflags new_expr) - setCmState new_cmstate + maybe_hv <- io (cmCompileExpr cms new_expr) case maybe_hv of Nothing -> return () Just hv -> io (writeIORef commands -- @@ -608,43 +608,43 @@ loadModule fs = timeIt (loadModule' fs) loadModule' :: [FilePath] -> GHCi () loadModule' files = do state <- getGHCiState - dflags <- io getDynFlags -- expand tildes files <- mapM expandPath files -- do the dependency anal first, so that if it fails we don't throw -- away the current set of modules. - graph <- io (cmDepAnal (cmstate state) dflags files) + graph <- io (cmDepAnal (cmstate state) files) -- Dependency anal ok, now unload everything - cmstate1 <- io (cmUnload (cmstate state) dflags) + cmstate1 <- io (cmUnload (cmstate state)) setGHCiState state{ cmstate = cmstate1, targets = [] } io (revertCAFs) -- always revert CAFs on load. - (cmstate2, ok, mods) <- io (cmLoadModules cmstate1 dflags graph) + (cmstate2, ok, mods) <- io (cmLoadModules cmstate1 graph) setGHCiState state{ cmstate = cmstate2, targets = files } setContextAfterLoad mods + dflags <- io (getDynFlags) modulesLoadedMsg ok mods dflags reloadModule :: String -> GHCi () reloadModule "" = do state <- getGHCiState - dflags <- io getDynFlags case targets state of [] -> io (putStr "no current target\n") paths -> do -- do the dependency anal first, so that if it fails we don't throw -- away the current set of modules. - graph <- io (cmDepAnal (cmstate state) dflags paths) + graph <- io (cmDepAnal (cmstate state) paths) io (revertCAFs) -- always revert CAFs on reload. (cmstate1, ok, mods) - <- io (cmLoadModules (cmstate state) dflags graph) + <- io (cmLoadModules (cmstate state) graph) setGHCiState state{ cmstate=cmstate1 } setContextAfterLoad mods + dflags <- io getDynFlags modulesLoadedMsg ok mods dflags reloadModule _ = noArgs ":reload" @@ -671,9 +671,7 @@ modulesLoadedMsg ok mods dflags = typeOfExpr :: String -> GHCi () typeOfExpr str = do cms <- getCmState - dflags <- io getDynFlags - (new_cmstate, maybe_tystr) <- io (cmTypeOfExpr cms dflags str) - setCmState new_cmstate + maybe_tystr <- io (cmTypeOfExpr cms str) case maybe_tystr of Nothing -> return () Just tystr -> io (putStrLn tystr) @@ -696,56 +694,25 @@ browseCmd m = browseModule m exports_only = do cms <- getCmState - dflags <- io getDynFlags is_interpreted <- io (cmModuleIsInterpreted cms m) when (not is_interpreted && not exports_only) $ throwDyn (CmdLineError ("module `" ++ m ++ "' is not interpreted")) - -- temporarily set the context to the module we're interested in, + -- Temporarily set the context to the module we're interested in, -- just so we can get an appropriate PrintUnqualified (as,bs) <- io (cmGetContext cms) - cms1 <- io (if exports_only then cmSetContext cms dflags [] [prel,m] - else cmSetContext cms dflags [m] []) - cms2 <- io (cmSetContext cms1 dflags as bs) - - (cms3, things) <- io (cmBrowseModule cms2 dflags m exports_only) + cms1 <- io (if exports_only then cmSetContext cms [] [prel,m] + else cmSetContext cms [m] []) + cms2 <- io (cmSetContext cms1 as bs) - setCmState cms3 + things <- io (cmBrowseModule cms2 m exports_only) let unqual = cmGetPrintUnqual cms1 -- NOTE: cms1 with the new context - things' = filter wantToSee things - - wantToSee (AnId id) = not (isImplicitId id) - wantToSee (ADataCon _) = False -- They'll come via their TyCon - wantToSee _ = True - - thing_names = map getName things - - thingDecl thing@(AnId id) = ifaceTyThing True{-omit prags-} thing - - thingDecl thing@(AClass c) = - let rn_decl = ifaceTyThing True{-omit prags-} thing in - case rn_decl of - ClassDecl { tcdSigs = cons } -> - rn_decl{ tcdSigs = filter methodIsVisible cons } - other -> other - where - methodIsVisible (ClassOpSig n _ _ _) = n `elem` thing_names - - thingDecl thing@(ATyCon t) = - let rn_decl = ifaceTyThing True{-omit prags-} thing in - case rn_decl of - TyData { tcdCons = DataCons cons } -> - rn_decl{ tcdCons = DataCons (filter conIsVisible cons) } - other -> other - where - conIsVisible (ConDecl n _ _ _ _) = n `elem` thing_names - io (putStrLn (showSDocForUser unqual ( - vcat (map (ppr . thingDecl) things'))) - ) + vcat (map ppr things) + ))) ----------------------------------------------------------------------------- -- Setting the module context @@ -764,10 +731,9 @@ setContext str newContext mods = do cms <- getCmState - dflags <- io getDynFlags (as,bs) <- separate cms mods [] [] let bs' = if null as && prel `notElem` bs then prel:bs else bs - cms' <- io (cmSetContext cms dflags as bs') + cms' <- io (cmSetContext cms as bs') setCmState cms' separate cmstate [] as bs = return (as,bs) @@ -782,7 +748,6 @@ prel = "Prelude" addToContext mods = do cms <- getCmState - dflags <- io getDynFlags (as,bs) <- io (cmGetContext cms) (as',bs') <- separate cms mods [] [] @@ -790,14 +755,13 @@ addToContext mods = do let as_to_add = as' \\ (as ++ bs) bs_to_add = bs' \\ (as ++ bs) - cms' <- io (cmSetContext cms dflags + cms' <- io (cmSetContext cms (as ++ as_to_add) (bs ++ bs_to_add)) setCmState cms' removeFromContext mods = do cms <- getCmState - dflags <- io getDynFlags (as,bs) <- io (cmGetContext cms) (as_to_remove,bs_to_remove) <- separate cms mods [] [] @@ -805,7 +769,7 @@ removeFromContext mods = do let as' = as \\ (as_to_remove ++ bs_to_remove) bs' = bs \\ (as_to_remove ++ bs_to_remove) - cms' <- io (cmSetContext cms dflags as' bs') + cms' <- io (cmSetContext cms as' bs') setCmState cms' ---------------------------------------------------------------------------- @@ -924,9 +888,9 @@ optToStr RevertCAFs = "r" newPackages new_pkgs = do -- The new packages are already in v_Packages state <- getGHCiState - dflags <- io getDynFlags - cmstate1 <- io (cmUnload (cmstate state) dflags) + cmstate1 <- io (cmUnload (cmstate state)) setGHCiState state{ cmstate = cmstate1, targets = [] } + dflags <- io getDynFlags io (linkPackages dflags new_pkgs) setContextAfterLoad [] @@ -961,7 +925,8 @@ showBindings = do cms <- getCmState let unqual = cmGetPrintUnqual cms - showBinding b = putStrLn (showSDocForUser unqual (ppr (ifaceTyThing True{-omit prags-} b))) +-- showBinding b = putStrLn (showSDocForUser unqual (ppr (ifaceTyThing b))) + showBinding b = putStrLn (showSDocForUser unqual (ppr (getName b))) io (mapM_ showBinding (cmGetBindings cms)) return () diff --git a/ghc/compiler/ghci/Linker.lhs b/ghc/compiler/ghci/Linker.lhs index 8f9fa34b22..008c0b2e93 100644 --- a/ghc/compiler/ghci/Linker.lhs +++ b/ghc/compiler/ghci/Linker.lhs @@ -36,11 +36,10 @@ import DriverState ( v_Cmdline_frameworks, v_Framework_paths ) #endif import Finder ( findModule, findLinkable ) import HscTypes -import Name ( Name, nameModule, isExternalName, isWiredInName ) +import Name ( Name, nameModule, nameModuleName, isExternalName, isWiredInName ) import NameEnv import NameSet ( nameSetToList ) import Module -import FastString ( FastString(..), unpackFS ) import ListSetOps ( minusList ) import CmdLineOpts ( DynFlags(verbosity), getDynFlags ) import BasicTypes ( SuccessFlag(..), succeeded, failed ) @@ -144,7 +143,7 @@ filterNameMap mods env = filterNameEnv keep_elt env where keep_elt (n,_) = isExternalName n - && (moduleName (nameModule n) `elem` mods) + && (nameModuleName n `elem` mods) \end{code} @@ -308,8 +307,7 @@ preloadLib dflags lib_paths framework_paths lib_spec %************************************************************************ \begin{code} -linkExpr :: HscEnv -> PersistentCompilerState - -> UnlinkedBCO -> IO HValue +linkExpr :: HscEnv -> UnlinkedBCO -> IO HValue -- Link a single expression, *including* first linking packages and -- modules that this expression depends on. @@ -317,13 +315,14 @@ linkExpr :: HscEnv -> PersistentCompilerState -- Raises an IO exception if it can't find a compiled version of the -- dependents to link. -linkExpr hsc_env pcs root_ul_bco +linkExpr hsc_env root_ul_bco = do { -- Initialise the linker (if it's not been done already) initDynLinker -- Find what packages and linkables are required - ; (lnks, pkgs) <- getLinkDeps hpt pit needed_mods + ; eps <- readIORef (hsc_EPS hsc_env) + ; (lnks, pkgs) <- getLinkDeps hpt (eps_PIT eps) needed_mods -- Link the packages and modules required ; linkPackages dflags pkgs @@ -342,7 +341,6 @@ linkExpr hsc_env pcs root_ul_bco ; return root_hval }} where - pit = eps_PIT (pcs_EPS pcs) hpt = hsc_HPT hsc_env dflags = hsc_dflags hsc_env free_names = nameSetToList (bcoFreeNames root_ul_bco) @@ -473,9 +471,6 @@ findModuleLinkable_maybe lis mod [li] -> Just li many -> pprPanic "findModuleLinkable" (ppr mod) -filterModuleLinkables :: (ModuleName -> Bool) -> [Linkable] -> [Linkable] -filterModuleLinkables p ls = filter (p . linkableModName) ls - linkableInSet :: Linkable -> [Linkable] -> Bool linkableInSet l objs_loaded = case findModuleLinkable_maybe objs_loaded (linkableModName l) of @@ -650,8 +645,7 @@ unload_wkr dflags linkables pls objs_loaded' <- filterM (maybeUnload objs_to_keep) (objs_loaded pls) bcos_loaded' <- filterM (maybeUnload bcos_to_keep) (bcos_loaded pls) - let objs_retained = map linkableModName objs_loaded' - bcos_retained = map linkableModName bcos_loaded' + let bcos_retained = map linkableModName bcos_loaded' itbl_env' = filterNameMap bcos_retained (itbl_env pls) closure_env' = filterNameMap bcos_retained (closure_env pls) new_pls = pls { itbl_env = itbl_env', diff --git a/ghc/compiler/hsSyn/Convert.lhs b/ghc/compiler/hsSyn/Convert.lhs index ddc11adb13..fa48574bf2 100644 --- a/ghc/compiler/hsSyn/Convert.lhs +++ b/ghc/compiler/hsSyn/Convert.lhs @@ -14,12 +14,12 @@ import Language.Haskell.THSyntax as Meta import HsSyn as Hs ( HsExpr(..), HsLit(..), ArithSeqInfo(..), - HsStmtContext(..), TyClDecl(..), + HsStmtContext(..), TyClDecl(..), HsBang(..), Match(..), GRHSs(..), GRHS(..), HsPred(..), HsDecl(..), TyClDecl(..), InstDecl(..), ConDecl(..), Stmt(..), HsBinds(..), MonoBinds(..), Sig(..), Pat(..), HsConDetails(..), HsOverLit, BangType(..), - placeHolderType, HsType(..), HsTupCon(..), + placeHolderType, HsType(..), HsTyVarBndr(..), HsContext, mkSimpleMatch, mkHsForAllTy ) @@ -29,10 +29,8 @@ import Module ( mkModuleName ) import RdrHsSyn ( mkHsIntegral, mkHsFractional, mkClassDecl, mkTyData ) import OccName import SrcLoc ( SrcLoc, generatedSrcLoc ) -import TyCon ( DataConDetails(..) ) import Type ( Type ) -import BasicTypes( Boxity(..), RecFlag(Recursive), - NewOrData(..), StrictnessMark(..) ) +import BasicTypes( Boxity(..), RecFlag(Recursive), NewOrData(..) ) import ForeignCall ( Safety(..), CCallConv(..), CCallTarget(..), CExportSpec(..)) import HsDecls ( CImportSpec(..), ForeignImport(..), ForeignExport(..), @@ -59,13 +57,13 @@ mk_con con = case con of -> ConDecl (cName c) noExistentials noContext (InfixCon (mk_arg st1) (mk_arg st2)) loc0 where - mk_arg (IsStrict, ty) = BangType MarkedUserStrict (cvtType ty) - mk_arg (NotStrict, ty) = BangType NotMarkedStrict (cvtType ty) + mk_arg (IsStrict, ty) = BangType HsStrict (cvtType ty) + mk_arg (NotStrict, ty) = BangType HsNoBang (cvtType ty) mk_id_arg (i, IsStrict, ty) - = (vName i, BangType MarkedUserStrict (cvtType ty)) + = (vName i, BangType HsStrict (cvtType ty)) mk_id_arg (i, NotStrict, ty) - = (vName i, BangType NotMarkedStrict (cvtType ty)) + = (vName i, BangType HsNoBang (cvtType ty)) mk_derivs [] = Nothing mk_derivs cs = Just [HsClassP (tconName c) [] | c <- cs] @@ -80,24 +78,24 @@ cvt_top (TySynD tc tvs rhs) cvt_top (DataD ctxt tc tvs constrs derivs) = Left $ TyClD (mkTyData DataType (cvt_context ctxt, tconName tc, cvt_tvs tvs) - (DataCons (map mk_con constrs)) + (map mk_con constrs) (mk_derivs derivs) loc0) cvt_top (NewtypeD ctxt tc tvs constr derivs) = Left $ TyClD (mkTyData NewType (cvt_context ctxt, tconName tc, cvt_tvs tvs) - (DataCons [mk_con constr]) + [mk_con constr] (mk_derivs derivs) loc0) cvt_top (ClassD ctxt cl tvs decs) = Left $ TyClD (mkClassDecl (cvt_context ctxt, tconName cl, cvt_tvs tvs) noFunDeps sigs - (Just binds) loc0) + binds loc0) where (binds,sigs) = cvtBindsAndSigs decs cvt_top (InstanceD tys ty decs) - = Left $ InstD (InstDecl inst_ty binds sigs Nothing loc0) + = Left $ InstD (InstDecl inst_ty binds sigs loc0) where (binds, sigs) = cvtBindsAndSigs decs inst_ty = HsForAllTy Nothing @@ -314,7 +312,7 @@ cvtType ty = trans (root ty []) root t zs = (t,zs) trans (TupleT n,args) - | length args == n = HsTupleTy (HsTupCon Boxed n) args + | length args == n = HsTupleTy Boxed args | n == 0 = foldl HsAppTy (HsTyVar (tconName "()")) args | otherwise = foldl HsAppTy (HsTyVar (tconName ("(" ++ replicate (n-1) ',' ++ ")"))) args trans (ArrowT, [x,y]) = HsFunTy x y diff --git a/ghc/compiler/hsSyn/HsBinds.lhs b/ghc/compiler/hsSyn/HsBinds.lhs index b00b3e9776..34ebac6526 100644 --- a/ghc/compiler/hsSyn/HsBinds.lhs +++ b/ghc/compiler/hsSyn/HsBinds.lhs @@ -15,20 +15,16 @@ import {-# SOURCE #-} HsExpr ( HsExpr, pprExpr, GRHSs, pprPatBind ) -- friends: -import HsImpExp ( pprHsVar ) import HsPat ( Pat ) import HsTypes ( HsType ) -import PprCore ( {- instance Outputable (Expr a) -} ) --others: import Name ( Name ) -import PrelNames ( isUnboundName ) import NameSet ( NameSet, elemNameSet, nameSetToList ) -import BasicTypes ( RecFlag(..), FixitySig(..), Activation(..), IPName ) +import BasicTypes ( RecFlag(..), Activation(..), Fixity, IPName ) import Outputable import SrcLoc ( SrcLoc ) import Var ( TyVar ) -import Class ( DefMeth (..) ) \end{code} %************************************************************************ @@ -248,12 +244,6 @@ data Sig name (HsType name) SrcLoc - | ClassOpSig name -- Selector name - (DefMeth name) -- Default-method info - -- See "THE NAMING STORY" in HsDecls - (HsType name) - SrcLoc - | SpecSig name -- specialise a function or datatype ... (HsType name) -- ... to these types SrcLoc @@ -268,15 +258,15 @@ data Sig name SrcLoc | FixSig (FixitySig name) -- Fixity declaration + +data FixitySig name = FixitySig name Fixity SrcLoc \end{code} \begin{code} okBindSig :: NameSet -> Sig Name -> Bool -okBindSig ns (ClassOpSig _ _ _ _) = False okBindSig ns sig = sigForThisGroup ns sig okClsDclSig :: Sig Name -> Bool -okClsDclSig (Sig _ _ _) = False okClsDclSig (SpecInstSig _ _) = False okClsDclSig sig = True -- All others OK @@ -286,39 +276,38 @@ okInstDclSig ns (FixSig _) = False okInstDclSig ns (SpecInstSig _ _) = True okInstDclSig ns sig = sigForThisGroup ns sig +sigForThisGroup :: NameSet -> Sig Name -> Bool sigForThisGroup ns sig = case sigName sig of - Nothing -> False - Just n | isUnboundName n -> True -- Don't complain about an unbound name again - | otherwise -> n `elemNameSet` ns + Nothing -> False + Just n -> n `elemNameSet` ns sigName :: Sig name -> Maybe name sigName (Sig n _ _) = Just n -sigName (ClassOpSig n _ _ _) = Just n sigName (SpecSig n _ _) = Just n sigName (InlineSig _ n _ _) = Just n sigName (FixSig (FixitySig n _ _)) = Just n sigName other = Nothing +sigLoc :: Sig name -> SrcLoc +sigLoc (Sig _ _ loc) = loc +sigLoc (SpecSig _ _ loc) = loc +sigLoc (InlineSig _ _ _ loc) = loc +sigLoc (FixSig (FixitySig n _ loc)) = loc +sigLoc (SpecInstSig _ loc) = loc + isFixitySig :: Sig name -> Bool isFixitySig (FixSig _) = True isFixitySig _ = False -isClassOpSig :: Sig name -> Bool -isClassOpSig (ClassOpSig _ _ _ _) = True -isClassOpSig _ = False - isPragSig :: Sig name -> Bool -- Identifies pragmas isPragSig (SpecSig _ _ _) = True isPragSig (InlineSig _ _ _ _) = True isPragSig (SpecInstSig _ _) = True isPragSig other = False -\end{code} -\begin{code} hsSigDoc (Sig _ _ loc) = (ptext SLIT("type signature"),loc) -hsSigDoc (ClassOpSig _ _ _ loc) = (ptext SLIT("class-method type signature"), loc) hsSigDoc (SpecSig _ _ loc) = (ptext SLIT("SPECIALISE pragma"),loc) hsSigDoc (InlineSig True _ _ loc) = (ptext SLIT("INLINE pragma"),loc) hsSigDoc (InlineSig False _ _ loc) = (ptext SLIT("NOINLINE pragma"),loc) @@ -326,6 +315,19 @@ hsSigDoc (SpecInstSig _ loc) = (ptext SLIT("SPECIALISE instance pragma"),l hsSigDoc (FixSig (FixitySig _ _ loc)) = (ptext SLIT("fixity declaration"), loc) \end{code} +Signature equality is used when checking for duplicate signatures + +\begin{code} +eqHsSig :: Sig Name -> Sig Name -> Bool +eqHsSig (FixSig (FixitySig n1 _ _)) (FixSig (FixitySig n2 _ _)) = n1 == n2 +eqHsSig (Sig n1 _ _) (Sig n2 _ _) = n1 == n2 +eqHsSig (InlineSig b1 n1 _ _) (InlineSig b2 n2 _ _) = b1 == b2 && n1 == n2 + -- For specialisations, we don't have equality over + -- HsType, so it's not convenient to spot duplicate + -- specialisations here. Check for this later, when we're in Type land +eqHsSig _other1 _other2 = False +\end{code} + \begin{code} instance (Outputable name) => Outputable (Sig name) where ppr sig = ppr_sig sig @@ -334,20 +336,6 @@ ppr_sig :: Outputable name => Sig name -> SDoc ppr_sig (Sig var ty _) = sep [ppr var <+> dcolon, nest 4 (ppr ty)] -ppr_sig (ClassOpSig var dm ty _) - = sep [ pprHsVar var <+> dcolon, - nest 4 (ppr ty), - nest 4 (pp_dm_comment) ] - where - pp_dm = case dm of - DefMeth _ -> equals -- Default method indicator - GenDefMeth -> semi -- Generic method indicator - NoDefMeth -> empty -- No Method at all - pp_dm_comment = case dm of - DefMeth _ -> text "{- has default method -}" - GenDefMeth -> text "{- has generic method -}" - NoDefMeth -> empty -- No Method at all - ppr_sig (SpecSig var ty _) = sep [ hsep [text "{-# SPECIALIZE", ppr var, dcolon], nest 4 (ppr ty <+> text "#-}") @@ -363,21 +351,7 @@ ppr_sig (SpecInstSig ty _) = hsep [text "{-# SPECIALIZE instance", ppr ty, text "#-}"] ppr_sig (FixSig fix_sig) = ppr fix_sig -\end{code} - -Checking for distinct signatures; oh, so boring - -\begin{code} -eqHsSig :: Sig Name -> Sig Name -> Bool -eqHsSig (Sig n1 _ _) (Sig n2 _ _) = n1 == n2 -eqHsSig (InlineSig b1 n1 _ _)(InlineSig b2 n2 _ _) = b1 == b2 && n1 == n2 - -eqHsSig (SpecInstSig ty1 _) (SpecInstSig ty2 _) = ty1 == ty2 -eqHsSig (SpecSig n1 ty1 _) (SpecSig n2 ty2 _) = - -- may have many specialisations for one value; - -- but not ones that are exactly the same... - (n1 == n2) && (ty1 == ty2) - -eqHsSig _other1 _other2 = False +instance Outputable name => Outputable (FixitySig name) where + ppr (FixitySig name fixity loc) = sep [ppr fixity, ppr name] \end{code} diff --git a/ghc/compiler/hsSyn/HsDecls.lhs b/ghc/compiler/hsSyn/HsDecls.lhs index d5e9c07f13..547da2738b 100644 --- a/ghc/compiler/hsSyn/HsDecls.lhs +++ b/ghc/compiler/hsSyn/HsDecls.lhs @@ -12,15 +12,14 @@ module HsDecls ( DefaultDecl(..), HsGroup(..), SpliceDecl(..), ForeignDecl(..), ForeignImport(..), ForeignExport(..), CImportSpec(..), FoType(..), - ConDecl(..), CoreDecl(..), - BangType(..), getBangType, getBangStrictness, unbangedType, - DeprecDecl(..), DeprecTxt, + ConDecl(..), + BangType(..), HsBang(..), getBangType, getBangStrictness, unbangedType, + DeprecDecl(..), tyClDeclName, tyClDeclNames, tyClDeclTyVars, - isClassDecl, isSynDecl, isDataDecl, isIfaceSigDecl, - isTypeOrClassDecl, countTyClDecls, - isSourceInstDecl, instDeclDFun, ifaceRuleDeclName, + isClassDecl, isSynDecl, isDataDecl, + countTyClDecls, conDetailsTys, - collectRuleBndrSigTys, isSrcRule + collectRuleBndrSigTys, ) where #include "HsVersions.h" @@ -29,31 +28,24 @@ module HsDecls ( import {-# SOURCE #-} HsExpr( HsExpr, pprExpr ) -- Because Expr imports Decls via HsBracket -import HsBinds ( HsBinds, MonoBinds, Sig(..) ) +import HsBinds ( HsBinds, MonoBinds, Sig(..), FixitySig ) import HsPat ( HsConDetails(..), hsConArgs ) import HsImpExp ( pprHsVar ) import HsTypes -import PprCore ( pprCoreRule ) -import HsCore ( UfExpr, UfBinder, HsIdInfo, pprHsIdInfo, - eq_ufBinders, eq_ufExpr, pprUfExpr - ) -import CoreSyn ( CoreRule(..), RuleName ) -import BasicTypes ( NewOrData(..), StrictnessMark(..), Activation(..), FixitySig(..) ) +import HscTypes ( DeprecTxt ) +import CoreSyn ( RuleName ) +import BasicTypes ( NewOrData(..), Activation(..) ) import ForeignCall ( CCallTarget(..), DNCallSpec, CCallConv, Safety, CExportSpec(..)) -- others: -import Name ( NamedThing ) import FunDeps ( pprFundeps ) -import TyCon ( DataConDetails(..), visibleDataCons ) -import Class ( FunDep, DefMeth(..) ) +import Class ( FunDep ) import CStrings ( CLabelString ) import Outputable -import Util ( eqListBy, count ) +import Util ( count ) import SrcLoc ( SrcLoc ) import FastString - -import Maybe ( isNothing, fromJust ) \end{code} @@ -73,7 +65,6 @@ data HsDecl id | ForD (ForeignDecl id) | DeprecD (DeprecDecl id) | RuleD (RuleDecl id) - | CoreD (CoreDecl id) | SpliceD (SpliceDecl id) -- NB: all top-level fixity decls are contained EITHER @@ -109,8 +100,7 @@ data HsGroup id hs_defds :: [DefaultDecl id], hs_fords :: [ForeignDecl id], hs_depds :: [DeprecDecl id], - hs_ruleds :: [RuleDecl id], - hs_coreds :: [CoreDecl id] + hs_ruleds :: [RuleDecl id] } \end{code} @@ -124,7 +114,6 @@ instance OutputableBndr name => Outputable (HsDecl name) where ppr (SigD sd) = ppr sd ppr (RuleD rd) = ppr rd ppr (DeprecD dd) = ppr dd - ppr (CoreD dd) = ppr dd ppr (SpliceD dd) = ppr dd instance OutputableBndr name => Outputable (HsGroup name) where @@ -135,13 +124,12 @@ instance OutputableBndr name => Outputable (HsGroup name) where hs_depds = deprec_decls, hs_fords = foreign_decls, hs_defds = default_decls, - hs_ruleds = rule_decls, - hs_coreds = core_decls }) + hs_ruleds = rule_decls }) = vcat [ppr_ds fix_decls, ppr_ds default_decls, ppr_ds deprec_decls, ppr_ds rule_decls, ppr val_decls, ppr_ds tycl_decls, ppr_ds inst_decls, - ppr_ds foreign_decls, ppr_ds core_decls] + ppr_ds foreign_decls] where ppr_ds [] = empty ppr_ds ds = text "" $$ vcat (map ppr ds) @@ -298,13 +286,7 @@ Interface file code: -- are both in TyClDecl data TyClDecl name - = IfaceSig { tcdName :: name, -- It may seem odd to classify an interface-file signature - tcdType :: HsType name, -- as a 'TyClDecl', but it's very convenient. - tcdIdInfo :: [HsIdInfo name], - tcdLoc :: SrcLoc - } - - | ForeignType { tcdName :: name, -- See remarks about IfaceSig above + = ForeignType { tcdName :: name, tcdExtName :: Maybe FastString, tcdFoType :: FoType, tcdLoc :: SrcLoc } @@ -313,19 +295,13 @@ data TyClDecl name tcdCtxt :: HsContext name, -- Context tcdName :: name, -- Type constructor tcdTyVars :: [HsTyVarBndr name], -- Type variables - tcdCons :: DataConDetails (ConDecl name), -- Data constructors + tcdCons :: [ConDecl name], -- Data constructors tcdDerivs :: Maybe (HsContext name), -- Derivings; Nothing => not specified -- Just [] => derive exactly what is asked - tcdGeneric :: Maybe Bool, -- Nothing <=> source decl - -- Just x <=> interface-file decl; - -- x=True <=> generic converter functions available - -- We need this for imported data decls, since the - -- imported modules may have been compiled with - -- different flags to the current compilation unit tcdLoc :: SrcLoc } - | TySynonym { tcdName :: name, -- type constructor + | TySynonym { tcdName :: name, -- type constructor tcdTyVars :: [HsTyVarBndr name], -- type variables tcdSynRhs :: HsType name, -- synonym expansion tcdLoc :: SrcLoc @@ -336,20 +312,15 @@ data TyClDecl name tcdTyVars :: [HsTyVarBndr name], -- The class type variables tcdFDs :: [FunDep name], -- Functional dependencies tcdSigs :: [Sig name], -- Methods' signatures - tcdMeths :: Maybe (MonoBinds name), -- Default methods - -- Nothing for imported class decls - -- Just bs for source class decls - tcdLoc :: SrcLoc + tcdMeths :: MonoBinds name, -- Default methods + tcdLoc :: SrcLoc } \end{code} Simple classifiers \begin{code} -isIfaceSigDecl, isDataDecl, isSynDecl, isClassDecl :: TyClDecl name -> Bool - -isIfaceSigDecl (IfaceSig {}) = True -isIfaceSigDecl other = False +isDataDecl, isSynDecl, isClassDecl :: TyClDecl name -> Bool isSynDecl (TySynonym {}) = True isSynDecl other = False @@ -359,12 +330,6 @@ isDataDecl other = False isClassDecl (ClassDecl {}) = True isClassDecl other = False - -isTypeOrClassDecl (ClassDecl {}) = True -isTypeOrClassDecl (TyData {}) = True -isTypeOrClassDecl (TySynonym {}) = True -isTypeOrClassDecl (ForeignType {}) = True -isTypeOrClassDecl other = False \end{code} Dealing with names @@ -382,87 +347,26 @@ tyClDeclNames :: Eq name => TyClDecl name -> [(name, SrcLoc)] -- We use the equality to filter out duplicate field names tyClDeclNames (TySynonym {tcdName = name, tcdLoc = loc}) = [(name,loc)] -tyClDeclNames (IfaceSig {tcdName = name, tcdLoc = loc}) = [(name,loc)] tyClDeclNames (ForeignType {tcdName = name, tcdLoc = loc}) = [(name,loc)] tyClDeclNames (ClassDecl {tcdName = cls_name, tcdSigs = sigs, tcdLoc = loc}) - = (cls_name,loc) : [(n,loc) | ClassOpSig n _ _ loc <- sigs] + = (cls_name,loc) : [(n,loc) | Sig n _ loc <- sigs] tyClDeclNames (TyData {tcdName = tc_name, tcdCons = cons, tcdLoc = loc}) = (tc_name,loc) : conDeclsNames cons - tyClDeclTyVars (TySynonym {tcdTyVars = tvs}) = tvs tyClDeclTyVars (TyData {tcdTyVars = tvs}) = tvs tyClDeclTyVars (ClassDecl {tcdTyVars = tvs}) = tvs tyClDeclTyVars (ForeignType {}) = [] -tyClDeclTyVars (IfaceSig {}) = [] -\end{code} - -\begin{code} -instance (NamedThing name, Ord name) => Eq (TyClDecl name) where - -- Used only when building interface files - (==) d1@(IfaceSig {}) d2@(IfaceSig {}) - = tcdName d1 == tcdName d2 && - tcdType d1 == tcdType d2 && - tcdIdInfo d1 == tcdIdInfo d2 - - (==) d1@(ForeignType {}) d2@(ForeignType {}) - = tcdName d1 == tcdName d2 && - tcdFoType d1 == tcdFoType d2 - - (==) d1@(TyData {}) d2@(TyData {}) - = tcdName d1 == tcdName d2 && - tcdND d1 == tcdND d2 && - eqWithHsTyVars (tcdTyVars d1) (tcdTyVars d2) (\ env -> - eq_hsContext env (tcdCtxt d1) (tcdCtxt d2) && - eq_hsCD env (tcdCons d1) (tcdCons d2) - ) - - (==) d1@(TySynonym {}) d2@(TySynonym {}) - = tcdName d1 == tcdName d2 && - eqWithHsTyVars (tcdTyVars d1) (tcdTyVars d2) (\ env -> - eq_hsType env (tcdSynRhs d1) (tcdSynRhs d2) - ) - - (==) d1@(ClassDecl {}) d2@(ClassDecl {}) - = tcdName d1 == tcdName d2 && - eqWithHsTyVars (tcdTyVars d1) (tcdTyVars d2) (\ env -> - eq_hsContext env (tcdCtxt d1) (tcdCtxt d2) && - eqListBy (eq_hsFD env) (tcdFDs d1) (tcdFDs d2) && - eqListBy (eq_cls_sig env) (tcdSigs d1) (tcdSigs d2) - ) - - (==) _ _ = False -- default case - -eq_hsCD env (DataCons c1) (DataCons c2) = eqListBy (eq_ConDecl env) c1 c2 -eq_hsCD env Unknown Unknown = True -eq_hsCD env (HasCons n1) (HasCons n2) = n1 == n2 -eq_hsCD env d1 d2 = False - -eq_hsFD env (ns1,ms1) (ns2,ms2) - = eqListBy (eq_hsVar env) ns1 ns2 && eqListBy (eq_hsVar env) ms1 ms2 - -eq_cls_sig env (ClassOpSig n1 dm1 ty1 _) (ClassOpSig n2 dm2 ty2 _) - = n1==n2 && dm1 `eq_dm` dm2 && eq_hsType env ty1 ty2 - where - -- Ignore the name of the default method for (DefMeth id) - -- This is used for comparing declarations before putting - -- them into interface files, and the name of the default - -- method isn't relevant - NoDefMeth `eq_dm` NoDefMeth = True - GenDefMeth `eq_dm` GenDefMeth = True - DefMeth _ `eq_dm` DefMeth _ = True - dm1 `eq_dm` dm2 = False \end{code} \begin{code} -countTyClDecls :: [TyClDecl name] -> (Int, Int, Int, Int, Int) +countTyClDecls :: [TyClDecl name] -> (Int, Int, Int, Int) -- class, data, newtype, synonym decls countTyClDecls decls = (count isClassDecl decls, count isSynDecl decls, - count isIfaceSigDecl decls, count isDataTy decls, count isNewTy decls) where @@ -477,10 +381,6 @@ countTyClDecls decls instance OutputableBndr name => Outputable (TyClDecl name) where - ppr (IfaceSig {tcdName = var, tcdType = ty, tcdIdInfo = info}) - = getPprStyle $ \ sty -> - hsep [ pprHsVar var, dcolon, ppr ty, pprHsIdInfo info ] - ppr (ForeignType {tcdName = tycon}) = hsep [ptext SLIT("foreign import type dotnet"), ppr tycon] @@ -491,13 +391,9 @@ instance OutputableBndr name ppr (TyData {tcdND = new_or_data, tcdCtxt = context, tcdName = tycon, tcdTyVars = tyvars, tcdCons = condecls, tcdDerivs = derivings}) - = pp_tydecl (ptext keyword <+> pp_decl_head context tycon tyvars) + = pp_tydecl (ppr new_or_data <+> pp_decl_head context tycon tyvars) (pp_condecls condecls) derivings - where - keyword = case new_or_data of - NewType -> SLIT("newtype") - DataType -> SLIT("data") ppr (ClassDecl {tcdCtxt = context, tcdName = clas, tcdTyVars = tyvars, tcdFDs = fds, tcdSigs = sigs, tcdMeths = methods}) @@ -506,21 +402,15 @@ instance OutputableBndr name | otherwise -- Laid out = sep [hsep [top_matter, ptext SLIT("where {")], - nest 4 (sep [sep (map ppr_sig sigs), pp_methods, char '}'])] + nest 4 (sep [sep (map ppr_sig sigs), ppr methods, char '}'])] where top_matter = ptext SLIT("class") <+> pp_decl_head context clas tyvars <+> pprFundeps fds ppr_sig sig = ppr sig <> semi - pp_methods = if isNothing methods - then empty - else ppr (fromJust methods) - pp_decl_head :: OutputableBndr name => HsContext name -> name -> [HsTyVarBndr name] -> SDoc pp_decl_head context thing tyvars = hsep [pprHsContext context, ppr thing, interppSP tyvars] -pp_condecls Unknown = ptext SLIT("{- abstract -}") -pp_condecls (HasCons n) = ptext SLIT("{- abstract with") <+> int n <+> ptext SLIT("constructors -}") -pp_condecls (DataCons cs) = equals <+> sep (punctuate (ptext SLIT(" |")) (map ppr cs)) +pp_condecls cs = equals <+> sep (punctuate (ptext SLIT(" |")) (map ppr cs)) pp_tydecl pp_head pp_decl_rhs derivings = hang pp_head 4 (sep [ @@ -552,12 +442,12 @@ data ConDecl name \end{code} \begin{code} -conDeclsNames :: Eq name => DataConDetails (ConDecl name) -> [(name,SrcLoc)] +conDeclsNames :: Eq name => [ConDecl name] -> [(name,SrcLoc)] -- See tyClDeclNames for what this does -- The function is boringly complicated because of the records -- And since we only have equality, we have to be a little careful conDeclsNames cons - = snd (foldl do_one ([], []) (visibleDataCons cons)) + = snd (foldl do_one ([], []) cons) where do_one (flds_seen, acc) (ConDecl name _ _ (RecCon flds) loc) = (new_flds ++ flds_seen, (name,loc) : [(f,loc) | f <- new_flds] ++ acc) @@ -566,38 +456,21 @@ conDeclsNames cons do_one (flds_seen, acc) (ConDecl name _ _ _ loc) = (flds_seen, (name,loc):acc) -\end{code} -\begin{code} conDetailsTys details = map getBangType (hsConArgs details) - -eq_ConDecl env (ConDecl n1 tvs1 cxt1 cds1 _) - (ConDecl n2 tvs2 cxt2 cds2 _) - = n1 == n2 && - (eq_hsTyVars env tvs1 tvs2 $ \ env -> - eq_hsContext env cxt1 cxt2 && - eq_ConDetails env cds1 cds2) - -eq_ConDetails env (PrefixCon bts1) (PrefixCon bts2) - = eqListBy (eq_btype env) bts1 bts2 -eq_ConDetails env (InfixCon bta1 btb1) (InfixCon bta2 btb2) - = eq_btype env bta1 bta2 && eq_btype env btb1 btb2 -eq_ConDetails env (RecCon fs1) (RecCon fs2) - = eqListBy (eq_fld env) fs1 fs2 -eq_ConDetails env _ _ = False - -eq_fld env (ns1,bt1) (ns2, bt2) = ns1==ns2 && eq_btype env bt1 bt2 \end{code} \begin{code} -data BangType name = BangType StrictnessMark (HsType name) +data BangType name = BangType HsBang (HsType name) + +data HsBang = HsNoBang + | HsStrict -- ! + | HsUnbox -- !! (GHC extension, meaning "unbox") getBangType (BangType _ ty) = ty getBangStrictness (BangType s _) = s -unbangedType ty = BangType NotMarkedStrict ty - -eq_btype env (BangType s1 t1) (BangType s2 t2) = s1==s2 && eq_hsType env t1 t2 +unbangedType ty = BangType HsNoBang ty \end{code} \begin{code} @@ -606,24 +479,28 @@ instance (OutputableBndr name) => Outputable (ConDecl name) where = sep [pprHsForAll tvs cxt, ppr_con_details con con_details] ppr_con_details con (InfixCon ty1 ty2) - = hsep [ppr_bang ty1, ppr con, ppr_bang ty2] + = hsep [ppr ty1, ppr con, ppr ty2] -- ConDecls generated by MkIface.ifaceTyThing always have a PrefixCon, even -- if the constructor is an infix one. This is because in an interface file -- we don't distinguish between the two. Hence when printing these for the -- user, we need to parenthesise infix constructor names. ppr_con_details con (PrefixCon tys) - = hsep (pprHsVar con : map ppr_bang tys) + = hsep (pprHsVar con : map ppr tys) ppr_con_details con (RecCon fields) = ppr con <+> braces (sep (punctuate comma (map ppr_field fields))) where - ppr_field (n, ty) = ppr n <+> dcolon <+> ppr_bang ty + ppr_field (n, ty) = ppr n <+> dcolon <+> ppr ty instance OutputableBndr name => Outputable (BangType name) where - ppr = ppr_bang - -ppr_bang (BangType s ty) = ppr s <> pprParendHsType ty + ppr (BangType is_strict ty) + = bang <> pprParendHsType ty + where + bang = case is_strict of + HsNoBang -> empty + HsStrict -> char '!' + HsUnbox -> ptext SLIT("!!") \end{code} @@ -638,44 +515,18 @@ data InstDecl name = InstDecl (HsType name) -- Context => Class Instance-type -- Using a polytype means that the renamer conveniently -- figures out the quantified type variables for us. - (MonoBinds name) - [Sig name] -- User-supplied pragmatic info - - (Maybe name) -- Name for the dictionary function - -- Nothing for source-file instance decls - SrcLoc -isSourceInstDecl :: InstDecl name -> Bool -isSourceInstDecl (InstDecl _ _ _ maybe_dfun _) = isNothing maybe_dfun - -instDeclDFun :: InstDecl name -> Maybe name -instDeclDFun (InstDecl _ _ _ df _) = df -- A Maybe, but that's ok -\end{code} - -\begin{code} instance (OutputableBndr name) => Outputable (InstDecl name) where - ppr (InstDecl inst_ty binds uprags maybe_dfun_name src_loc) + ppr (InstDecl inst_ty binds uprags src_loc) = vcat [hsep [ptext SLIT("instance"), ppr inst_ty, ptext SLIT("where")], nest 4 (ppr uprags), nest 4 (ppr binds) ] - where - pp_dfun = case maybe_dfun_name of - Just df -> ppr df - Nothing -> empty -\end{code} - -\begin{code} -instance Ord name => Eq (InstDecl name) where - -- Used for interface comparison only, so don't compare bindings - (==) (InstDecl inst_ty1 _ _ dfun1 _) (InstDecl inst_ty2 _ _ dfun2 _) - = inst_ty1 == inst_ty2 && dfun1 == dfun2 \end{code} - %************************************************************************ %* * \subsection[DefaultDecl]{A @default@ declaration} @@ -716,12 +567,6 @@ data ForeignDecl name = ForeignImport name (HsType name) ForeignImport Bool SrcLoc -- defines name | ForeignExport name (HsType name) ForeignExport Bool SrcLoc -- uses name --- yield the Haskell name defined or used in a foreign declaration --- -foreignDeclName :: ForeignDecl name -> name -foreignDeclName (ForeignImport n _ _ _ _) = n -foreignDeclName (ForeignExport n _ _ _ _) = n - -- specification of an imported external entity in dependence on the calling -- convention -- @@ -826,28 +671,6 @@ data RuleDecl name (HsExpr name) -- RHS SrcLoc - | IfaceRule -- One that's come in from an interface file; pre-typecheck - RuleName - Activation - [UfBinder name] -- Tyvars and term vars - name -- Head of lhs - [UfExpr name] -- Args of LHS - (UfExpr name) -- Pre typecheck - SrcLoc - - | IfaceRuleOut -- Post typecheck - name -- Head of LHS - CoreRule - -isSrcRule :: RuleDecl name -> Bool -isSrcRule (HsRule _ _ _ _ _ _) = True -isSrcRule other = False - -ifaceRuleDeclName :: RuleDecl name -> name -ifaceRuleDeclName (IfaceRule _ _ _ n _ _ _) = n -ifaceRuleDeclName (IfaceRuleOut n r) = n -ifaceRuleDeclName (HsRule fs _ _ _ _ _) = pprPanic "ifaceRuleDeclName" (ppr fs) - data RuleBndr name = RuleBndr name | RuleBndrSig name (HsType name) @@ -855,31 +678,15 @@ data RuleBndr name collectRuleBndrSigTys :: [RuleBndr name] -> [HsType name] collectRuleBndrSigTys bndrs = [ty | RuleBndrSig _ ty <- bndrs] -instance (NamedThing name, Ord name) => Eq (RuleDecl name) where - -- Works for IfaceRules only; used when comparing interface file versions - (IfaceRule n1 a1 bs1 f1 es1 rhs1 _) == (IfaceRule n2 a2 bs2 f2 es2 rhs2 _) - = n1==n2 && f1 == f2 && a1==a2 && - eq_ufBinders emptyEqHsEnv bs1 bs2 (\env -> - eqListBy (eq_ufExpr env) (rhs1:es1) (rhs2:es2)) - instance OutputableBndr name => Outputable (RuleDecl name) where ppr (HsRule name act ns lhs rhs loc) = sep [text "{-# RULES" <+> doubleQuotes (ftext name) <+> ppr act, - pp_forall, pprExpr lhs, equals <+> pprExpr rhs, - text "#-}" ] + nest 4 (pp_forall <+> pprExpr lhs), + nest 4 (equals <+> pprExpr rhs <+> text "#-}") ] where pp_forall | null ns = empty | otherwise = text "forall" <+> fsep (map ppr ns) <> dot - ppr (IfaceRule name act tpl_vars fn tpl_args rhs loc) - = hsep [ doubleQuotes (ftext name), ppr act, - ptext SLIT("__forall") <+> braces (interppSP tpl_vars), - ppr fn <+> sep (map (pprUfExpr parens) tpl_args), - ptext SLIT("=") <+> ppr rhs - ] <+> semi - - ppr (IfaceRuleOut fn rule) = pprCoreRule (ppr fn) rule - instance OutputableBndr name => Outputable (RuleBndr name) where ppr (RuleBndr name) = ppr name ppr (RuleBndrSig name ty) = ppr name <> dcolon <> ppr ty @@ -897,29 +704,7 @@ We use exported entities for things to deprecate. \begin{code} data DeprecDecl name = Deprecation name DeprecTxt SrcLoc -type DeprecTxt = FastString -- reason/explanation for deprecation - instance OutputableBndr name => Outputable (DeprecDecl name) where ppr (Deprecation thing txt _) = hsep [text "{-# DEPRECATED", ppr thing, doubleQuotes (ppr txt), text "#-}"] \end{code} - - -%************************************************************************ -%* * - External-core declarations -%* * -%************************************************************************ - -\begin{code} -data CoreDecl name -- a Core value binding (from 'external Core' input) - = CoreDecl name - (HsType name) - (UfExpr name) - SrcLoc - -instance OutputableBndr name => Outputable (CoreDecl name) where - ppr (CoreDecl var ty rhs loc) - = getPprStyle $ \ sty -> - hsep [ pprHsVar var, dcolon, ppr ty, ppr rhs ] -\end{code} diff --git a/ghc/compiler/hsSyn/HsExpr.lhs b/ghc/compiler/hsSyn/HsExpr.lhs index 9b2b64fc87..bc17aed3ba 100644 --- a/ghc/compiler/hsSyn/HsExpr.lhs +++ b/ghc/compiler/hsSyn/HsExpr.lhs @@ -11,9 +11,9 @@ module HsExpr where -- friends: import HsDecls ( HsGroup ) import HsBinds ( HsBinds(..), nullBinds ) -import HsPat ( Pat ) -import HsLit ( HsLit, HsOverLit ) -import HsTypes ( HsType, PostTcType, SyntaxName ) +import HsPat ( Pat(..), HsConDetails(..) ) +import HsLit ( HsLit(..), HsOverLit ) +import HsTypes ( HsType, PostTcType, SyntaxName, placeHolderType ) import HsImpExp ( isOperator, pprHsVar ) -- others: @@ -23,11 +23,47 @@ import Var ( TyVar, Id ) import Name ( Name ) import DataCon ( DataCon ) import BasicTypes ( IPName, Boxity, tupleParens, Fixity(..) ) -import SrcLoc ( SrcLoc ) +import SrcLoc ( SrcLoc, generatedSrcLoc ) import Outputable import FastString \end{code} + +%************************************************************************ +%* * + Some useful helpers for constructing expressions +%* * +%************************************************************************ + +\begin{code} +mkHsApps f xs = foldl HsApp (HsVar f) xs +mkHsVarApps f xs = foldl HsApp (HsVar f) (map HsVar xs) + +mkHsIntLit n = HsLit (HsInt n) +mkHsString s = HsString (mkFastString s) + +mkConPat con vars = ConPatIn con (PrefixCon (map VarPat vars)) +mkNullaryConPat con = ConPatIn con (PrefixCon []) + +mkSimpleHsAlt :: Pat id -> HsExpr id -> Match id +-- A simple lambda with a single pattern, no binds, no guards; pre-typechecking +mkSimpleHsAlt pat expr + = mkSimpleMatch [pat] expr placeHolderType generatedSrcLoc + +mkSimpleMatch :: [Pat id] -> HsExpr id -> Type -> SrcLoc -> Match id +mkSimpleMatch pats rhs rhs_ty locn + = Match pats Nothing (GRHSs (unguardedRHS rhs locn) EmptyBinds rhs_ty) + +unguardedRHS :: HsExpr id -> SrcLoc -> [GRHS id] +unguardedRHS rhs loc = [GRHS [ResultStmt rhs loc] loc] + +glueBindsOnGRHSs :: HsBinds id -> GRHSs id -> GRHSs id +glueBindsOnGRHSs EmptyBinds grhss = grhss +glueBindsOnGRHSs binds1 (GRHSs grhss binds2 ty) + = GRHSs grhss (binds1 `ThenBinds` binds2) ty +\end{code} + + %************************************************************************ %* * \subsection{Expressions proper} @@ -597,18 +633,6 @@ data GRHSs id data GRHS id = GRHS [Stmt id] -- The RHS is the final ResultStmt SrcLoc - -mkSimpleMatch :: [Pat id] -> HsExpr id -> Type -> SrcLoc -> Match id -mkSimpleMatch pats rhs rhs_ty locn - = Match pats Nothing (GRHSs (unguardedRHS rhs locn) EmptyBinds rhs_ty) - -unguardedRHS :: HsExpr id -> SrcLoc -> [GRHS id] -unguardedRHS rhs loc = [GRHS [ResultStmt rhs loc] loc] - -glueBindsOnGRHSs :: HsBinds id -> GRHSs id -> GRHSs id -glueBindsOnGRHSs EmptyBinds grhss = grhss -glueBindsOnGRHSs binds1 (GRHSs grhss binds2 ty) - = GRHSs grhss (binds1 `ThenBinds` binds2) ty \end{code} @getMatchLoc@ takes a @Match@ and returns the diff --git a/ghc/compiler/hsSyn/HsLit.lhs b/ghc/compiler/hsSyn/HsLit.lhs index 8eb18e278e..a41d323a47 100644 --- a/ghc/compiler/hsSyn/HsLit.lhs +++ b/ghc/compiler/hsSyn/HsLit.lhs @@ -9,7 +9,7 @@ module HsLit where #include "HsVersions.h" import Type ( Type ) -import HsTypes ( SyntaxName, PostTcType ) +import HsTypes ( SyntaxName ) import Outputable import FastString import Ratio ( Rational ) @@ -32,7 +32,7 @@ data HsLit | HsInt Integer -- Genuinely an Int; arises from TcGenDeriv, -- and from TRANSLATION | HsIntPrim Integer -- Unboxed Int - | HsInteger Integer -- Genuinely an integer; arises only from TRANSLATION + | HsInteger Integer Type -- Genuinely an integer; arises only from TRANSLATION -- (overloaded literals are done with HsOverLit) | HsRat Rational Type -- Genuinely a rational; arises only from TRANSLATION -- (overloaded literals are done with HsOverLit) @@ -46,7 +46,7 @@ instance Eq HsLit where (HsStringPrim x1) == (HsStringPrim x2) = x1==x2 (HsInt x1) == (HsInt x2) = x1==x2 (HsIntPrim x1) == (HsIntPrim x2) = x1==x2 - (HsInteger x1) == (HsInteger x2) = x1==x2 + (HsInteger x1 _) == (HsInteger x2 _) = x1==x2 (HsRat x1 _) == (HsRat x2 _) = x1==x2 (HsFloatPrim x1) == (HsFloatPrim x2) = x1==x2 (HsDoublePrim x1) == (HsDoublePrim x2) = x1==x2 @@ -58,9 +58,12 @@ data HsOverLit -- An overloaded literal | HsFractional Rational SyntaxName -- Frac-looking literals -- The name is fromRational +-- Comparison operations are needed when grouping literals +-- for compiling pattern-matching (module MatchLit) instance Eq HsOverLit where (HsIntegral i1 _) == (HsIntegral i2 _) = i1 == i2 (HsFractional f1 _) == (HsFractional f2 _) = f1 == f2 + l1 == l2 = False instance Ord HsOverLit where compare (HsIntegral i1 _) (HsIntegral i2 _) = i1 `compare` i2 @@ -77,7 +80,7 @@ instance Outputable HsLit where ppr (HsString s) = pprHsString s ppr (HsStringPrim s) = pprHsString s <> char '#' ppr (HsInt i) = integer i - ppr (HsInteger i) = integer i + ppr (HsInteger i _) = integer i ppr (HsRat f _) = rational f ppr (HsFloatPrim f) = rational f <> char '#' ppr (HsDoublePrim d) = rational d <> text "##" diff --git a/ghc/compiler/hsSyn/HsSyn.lhs b/ghc/compiler/hsSyn/HsSyn.lhs index 373a240a33..c996f22772 100644 --- a/ghc/compiler/hsSyn/HsSyn.lhs +++ b/ghc/compiler/hsSyn/HsSyn.lhs @@ -9,9 +9,6 @@ therefore, is almost nothing but re-exporting. \begin{code} module HsSyn ( - -- NB: don't reexport HsCore - -- this module tells about "real Haskell" - module HsBinds, module HsDecls, module HsExpr, @@ -21,7 +18,7 @@ module HsSyn ( module HsTypes, Fixity, NewOrData, - HsModule(..), + HsModule(..), HsExtCore(..), collectStmtsBinders, collectStmtBinders, collectHsBinders, collectLocatedHsBinders, collectMonoBinders, collectLocatedMonoBinders, @@ -38,10 +35,11 @@ import HsImpExp import HsLit import HsPat import HsTypes -import BasicTypes ( Fixity, Version, NewOrData ) +import HscTypes ( DeprecTxt ) +import BasicTypes ( Fixity, NewOrData ) -- others: -import Name ( NamedThing ) +import IfaceSyn ( IfaceBinding ) import Outputable import SrcLoc ( SrcLoc ) import Module ( Module ) @@ -63,10 +61,17 @@ data HsModule name [HsDecl name] -- Type, class, value, and interface signature decls (Maybe DeprecTxt) -- reason/explanation for deprecation of this module SrcLoc + +data HsExtCore name -- Read from Foo.hcr + = HsExtCore + Module + [TyClDecl name] -- Type declarations only; just as in Haskell source, + -- so that we can infer kinds etc + [IfaceBinding] -- And the bindings \end{code} \begin{code} -instance (NamedThing name, OutputableBndr name) +instance (OutputableBndr name) => Outputable (HsModule name) where ppr (HsModule Nothing _ imports decls _ src_loc) diff --git a/ghc/compiler/hsSyn/HsTypes.lhs b/ghc/compiler/hsSyn/HsTypes.lhs index 61321a4a52..79b662fab6 100644 --- a/ghc/compiler/hsSyn/HsTypes.lhs +++ b/ghc/compiler/hsSyn/HsTypes.lhs @@ -1,13 +1,12 @@ -% +]% % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % \section[HsTypes]{Abstract syntax: user-defined types} \begin{code} module HsTypes ( - HsType(..), HsTyVarBndr(..), HsTyOp(..), + HsType(..), HsTyVarBndr(..), , HsContext, HsPred(..) - , HsTupCon(..), hsTupParens, mkHsTupCon, , mkHsForAllTy, mkHsDictTy, mkHsIParamTy , hsTyVarName, hsTyVarNames, replaceTyVarName @@ -21,35 +20,18 @@ module HsTypes ( -- Printing , pprParendHsType, pprHsForAll, pprHsContext, ppr_hs_context, pprHsTyVarBndr - - -- Equality over Hs things - , EqHsEnv, emptyEqHsEnv, extendEqHsEnv, - , eqWithHsTyVars, eq_hsVar, eq_hsVars, eq_hsTyVars, eq_hsType, eq_hsContext, eqListBy - - -- Converting from Type to HsType - , toHsType, toHsTyVar, toHsTyVars, toHsContext, toHsFDs ) where #include "HsVersions.h" -import Class ( FunDep ) -import TcType ( Type, Kind, ThetaType, SourceType(..), - tcSplitSigmaTy, liftedTypeKind, eqKind, tcEqType - ) -import TypeRep ( Type(..), TyNote(..) ) -- toHsType sees the representation -import TyCon ( isTupleTyCon, tupleTyConBoxity, tyConArity, isNewTyCon, getSynTyConDefn ) -import RdrName ( mkUnqual ) -import Name ( Name, getName, mkInternalName ) -import OccName ( NameSpace, mkVarOcc, tvName ) -import Var ( TyVar, tyVarKind ) -import Subst ( substTyWith ) +import TcType ( Type, Kind, liftedTypeKind, eqKind ) +import TypeRep ( Type ) +import Name ( Name, mkInternalName ) +import OccName ( mkVarOcc ) import PprType ( {- instance Outputable Kind -}, pprParendKind, pprKind ) -import BasicTypes ( Boxity(..), Arity, IPName, tupleParens ) -import PrelNames ( listTyConKey, parrTyConKey, - hasKey, unboundKey ) +import BasicTypes ( IPName, Boxity, tupleParens ) +import PrelNames ( unboundKey ) import SrcLoc ( noSrcLoc ) -import Util ( eqListBy, lengthIs ) -import FiniteMap import Outputable \end{code} @@ -114,10 +96,10 @@ data HsType name | HsPArrTy (HsType name) -- Elem. type of parallel array: [:t:] - | HsTupleTy HsTupCon + | HsTupleTy Boxity [HsType name] -- Element types (length gives arity) - | HsOpTy (HsType name) (HsTyOp name) (HsType name) + | HsOpTy (HsType name) name (HsType name) | HsParTy (HsType name) -- Parenthesis preserved for the precedence re-arrangement in RnTypes @@ -136,23 +118,6 @@ data HsType name Kind -- A type with a kind signature -data HsTyOp name = HsArrow | HsTyOp name - -- Function arrows from *source* get read in as HsOpTy t1 HsArrow t2 - -- But when we generate or parse interface files, we use HsFunTy. - -- This keeps interfaces a bit smaller, because there are a lot of arrows - ------------------------ -data HsTupCon = HsTupCon Boxity Arity - -instance Eq HsTupCon where - (HsTupCon b1 a1) == (HsTupCon b2 a2) = b1==b2 && a1==a2 - -mkHsTupCon :: NameSpace -> Boxity -> [a] -> HsTupCon -mkHsTupCon space boxity args = HsTupCon boxity (length args) - -hsTupParens :: HsTupCon -> SDoc -> SDoc -hsTupParens (HsTupCon b _) p = tupleParens b p - ----------------------- -- Combine adjacent for-alls. -- The following awkward situation can happen otherwise: @@ -181,19 +146,19 @@ mkHsIParamTy v ty = HsPredTy (HsIParam v ty) data HsTyVarBndr name = UserTyVar name - | IfaceTyVar name Kind + | KindedTyVar name Kind -- *** NOTA BENE *** A "monotype" in a pragma can have -- for-alls in it, (mostly to do with dictionaries). These -- must be explicitly Kinded. -hsTyVarName (UserTyVar n) = n -hsTyVarName (IfaceTyVar n _) = n +hsTyVarName (UserTyVar n) = n +hsTyVarName (KindedTyVar n _) = n hsTyVarNames tvs = map hsTyVarName tvs replaceTyVarName :: HsTyVarBndr name1 -> name2 -> HsTyVarBndr name2 -replaceTyVarName (UserTyVar n) n' = UserTyVar n' -replaceTyVarName (IfaceTyVar n k) n' = IfaceTyVar n' k +replaceTyVarName (UserTyVar n) n' = UserTyVar n' +replaceTyVarName (KindedTyVar n k) n' = KindedTyVar n' k \end{code} @@ -249,13 +214,9 @@ NB: these types get printed into interface files, so instance (Outputable name) => Outputable (HsType name) where ppr ty = pprHsType ty -instance (Outputable name) => Outputable (HsTyOp name) where - ppr HsArrow = ftext FSLIT("->") - ppr (HsTyOp n) = ppr n - instance (Outputable name) => Outputable (HsTyVarBndr name) where - ppr (UserTyVar name) = ppr name - ppr (IfaceTyVar name kind) = pprHsTyVarBndr name kind + ppr (UserTyVar name) = ppr name + ppr (KindedTyVar name kind) = pprHsTyVarBndr name kind instance Outputable name => Outputable (HsPred name) where ppr (HsClassP clas tys) = ppr clas <+> hsep (map pprParendHsType tys) @@ -324,7 +285,7 @@ ppr_mono_ty ctxt_prec (HsForAllTy maybe_tvs ctxt ty) ppr_mono_ty ctxt_prec (HsTyVar name) = ppr name ppr_mono_ty ctxt_prec (HsFunTy ty1 ty2) = ppr_fun_ty ctxt_prec ty1 ty2 -ppr_mono_ty ctxt_prec (HsTupleTy con tys) = hsTupParens con (interpp'SP tys) +ppr_mono_ty ctxt_prec (HsTupleTy con tys) = tupleParens con (interpp'SP tys) ppr_mono_ty ctxt_prec (HsKindSig ty kind) = parens (ppr_mono_ty pREC_TOP ty <+> dcolon <+> pprKind kind) ppr_mono_ty ctxt_prec (HsListTy ty) = brackets (ppr_mono_ty pREC_TOP ty) ppr_mono_ty ctxt_prec (HsPArrTy ty) = pabrackets (ppr_mono_ty pREC_TOP ty) @@ -335,9 +296,6 @@ ppr_mono_ty ctxt_prec (HsAppTy fun_ty arg_ty) = maybeParen ctxt_prec pREC_CON $ hsep [ppr_mono_ty pREC_FUN fun_ty, ppr_mono_ty pREC_CON arg_ty] -ppr_mono_ty ctxt_prec (HsOpTy ty1 HsArrow ty2) - = ppr_fun_ty ctxt_prec ty1 ty2 - ppr_mono_ty ctxt_prec (HsOpTy ty1 op ty2) = maybeParen ctxt_prec pREC_OP $ ppr_mono_ty pREC_OP ty1 <+> ppr op <+> ppr_mono_ty pREC_OP ty2 @@ -361,197 +319,3 @@ pabrackets p = ptext SLIT("[:") <> p <> ptext SLIT(":]") \end{code} -%************************************************************************ -%* * -\subsection{Converting from Type to HsType} -%* * -%************************************************************************ - -@toHsType@ converts from a Type to a HsType, making the latter look as -user-friendly as possible. Notably, it uses synonyms where possible, and -expresses overloaded functions using the '=>' context part of a HsForAllTy. - -\begin{code} -toHsTyVar :: TyVar -> HsTyVarBndr Name -toHsTyVar tv = IfaceTyVar (getName tv) (tyVarKind tv) - -toHsTyVars tvs = map toHsTyVar tvs - -toHsType :: Type -> HsType Name --- This function knows the representation of types -toHsType (TyVarTy tv) = HsTyVar (getName tv) -toHsType (FunTy arg res) = HsFunTy (toHsType arg) (toHsType res) -toHsType (AppTy fun arg) = HsAppTy (toHsType fun) (toHsType arg) - -toHsType (NoteTy (SynNote ty@(TyConApp tycon tyargs)) real_ty) - | isNewTyCon tycon = toHsType ty - | syn_matches = toHsType ty -- Use synonyms if possible!! - | otherwise = -#ifdef DEBUG - pprTrace "WARNING: synonym info lost in .hi file for " (ppr syn_ty) $ -#endif - toHsType real_ty -- but drop it if not. - where - syn_matches = ty_from_syn `tcEqType` real_ty - (tyvars,syn_ty) = getSynTyConDefn tycon - ty_from_syn = substTyWith tyvars tyargs syn_ty - - -- We only use the type synonym in the file if this doesn't cause - -- us to lose important information. This matters for usage - -- annotations. It's an issue if some of the args to the synonym - -- have arrows in them, or if the synonym's RHS has an arrow; for - -- example, with nofib/real/ebnf2ps/ in Parsers.using. - - -- **! It would be nice if when this test fails we could still - -- write the synonym in as a Note, so we don't lose the info for - -- error messages, but it's too much work for right now. - -- KSW 2000-07. - -toHsType (NoteTy _ ty) = toHsType ty - -toHsType (SourceTy (NType tc tys)) = foldl HsAppTy (HsTyVar (getName tc)) (map toHsType tys) -toHsType (SourceTy pred) = HsPredTy (toHsPred pred) - -toHsType ty@(TyConApp tc tys) -- Must be saturated because toHsType's arg is of kind * - | not saturated = generic_case - | isTupleTyCon tc = HsTupleTy (HsTupCon (tupleTyConBoxity tc) (tyConArity tc)) tys' - | tc `hasKey` listTyConKey = HsListTy (head tys') - | tc `hasKey` parrTyConKey = HsPArrTy (head tys') - | otherwise = generic_case - where - generic_case = foldl HsAppTy (HsTyVar (getName tc)) tys' - tys' = map toHsType tys - saturated = tys `lengthIs` tyConArity tc - -toHsType ty@(ForAllTy _ _) = case tcSplitSigmaTy ty of - (tvs, preds, tau) -> HsForAllTy (Just (map toHsTyVar tvs)) - (map toHsPred preds) - (toHsType tau) - -toHsPred (ClassP cls tys) = HsClassP (getName cls) (map toHsType tys) -toHsPred (IParam n ty) = HsIParam n (toHsType ty) - -toHsContext :: ThetaType -> HsContext Name -toHsContext theta = map toHsPred theta - -toHsFDs :: [FunDep TyVar] -> [FunDep Name] -toHsFDs fds = [(map getName ns, map getName ms) | (ns,ms) <- fds] -\end{code} - - -%************************************************************************ -%* * -\subsection{Comparison} -%* * -%************************************************************************ - -\begin{code} -instance Ord a => Eq (HsType a) where - -- The Ord is needed because we keep a - -- finite map of variables to variables - (==) a b = eq_hsType emptyEqHsEnv a b - -instance Ord a => Eq (HsPred a) where - (==) a b = eq_hsPred emptyEqHsEnv a b - -eqWithHsTyVars :: Ord name => - [HsTyVarBndr name] -> [HsTyVarBndr name] - -> (EqHsEnv name -> Bool) -> Bool -eqWithHsTyVars = eq_hsTyVars emptyEqHsEnv -\end{code} - -\begin{code} -type EqHsEnv n = FiniteMap n n --- Tracks the mapping from L-variables to R-variables - -eq_hsVar :: Ord n => EqHsEnv n -> n -> n -> Bool -eq_hsVar env n1 n2 = case lookupFM env n1 of - Just n1 -> n1 == n2 - Nothing -> n1 == n2 - -extendEqHsEnv env n1 n2 - | n1 == n2 = env - | otherwise = addToFM env n1 n2 - -emptyEqHsEnv :: EqHsEnv n -emptyEqHsEnv = emptyFM -\end{code} - -We do define a specialised equality for these \tr{*Type} types; used -in checking interfaces. - -\begin{code} -------------------- -eq_hsTyVars env [] [] k = k env -eq_hsTyVars env (tv1:tvs1) (tv2:tvs2) k = eq_hsTyVar env tv1 tv2 $ \ env -> - eq_hsTyVars env tvs1 tvs2 k -eq_hsTyVars env _ _ _ = False - -eq_hsTyVar env (UserTyVar v1) (UserTyVar v2) k = k (extendEqHsEnv env v1 v2) -eq_hsTyVar env (IfaceTyVar v1 k1) (IfaceTyVar v2 k2) k = k1 `eqKind` k2 && k (extendEqHsEnv env v1 v2) -eq_hsTyVar env _ _ _ = False - -eq_hsVars env [] [] k = k env -eq_hsVars env (v1:bs1) (v2:bs2) k = eq_hsVars (extendEqHsEnv env v1 v2) bs1 bs2 k -eq_hsVars env _ _ _ = False -\end{code} - -\begin{code} -------------------- -eq_hsTypes env = eqListBy (eq_hsType env) - -------------------- -eq_hsType env (HsForAllTy tvs1 c1 t1) (HsForAllTy tvs2 c2 t2) - = eq_tvs tvs1 tvs2 $ \env -> - eq_hsContext env c1 c2 && - eq_hsType env t1 t2 - where - eq_tvs Nothing (Just _) k = False - eq_tvs Nothing Nothing k = k env - eq_tvs (Just _) Nothing k = False - eq_tvs (Just tvs1) (Just tvs2) k = eq_hsTyVars env tvs1 tvs2 k - -eq_hsType env (HsTyVar n1) (HsTyVar n2) - = eq_hsVar env n1 n2 - -eq_hsType env (HsTupleTy c1 tys1) (HsTupleTy c2 tys2) - = (c1 == c2) && eq_hsTypes env tys1 tys2 - -eq_hsType env (HsListTy ty1) (HsListTy ty2) - = eq_hsType env ty1 ty2 - -eq_hsType env (HsKindSig ty1 k1) (HsKindSig ty2 k2) - = eq_hsType env ty1 ty2 && k1 `eqKind` k2 - -eq_hsType env (HsPArrTy ty1) (HsPArrTy ty2) - = eq_hsType env ty1 ty2 - -eq_hsType env (HsAppTy fun_ty1 arg_ty1) (HsAppTy fun_ty2 arg_ty2) - = eq_hsType env fun_ty1 fun_ty2 && eq_hsType env arg_ty1 arg_ty2 - -eq_hsType env (HsFunTy a1 b1) (HsFunTy a2 b2) - = eq_hsType env a1 a2 && eq_hsType env b1 b2 - -eq_hsType env (HsPredTy p1) (HsPredTy p2) - = eq_hsPred env p1 p2 - -eq_hsType env (HsOpTy lty1 op1 rty1) (HsOpTy lty2 op2 rty2) - = eq_hsOp env op1 op2 && eq_hsType env lty1 lty2 && eq_hsType env rty1 rty2 - -eq_hsType env ty1 ty2 = False - - -eq_hsOp env (HsTyOp n1) (HsTyOp n2) = eq_hsVar env n1 n2 -eq_hsOp env HsArrow HsArrow = True -eq_hsOp env op1 op2 = False - -------------------- -eq_hsContext env a b = eqListBy (eq_hsPred env) a b - -------------------- -eq_hsPred env (HsClassP c1 tys1) (HsClassP c2 tys2) - = c1 == c2 && eq_hsTypes env tys1 tys2 -eq_hsPred env (HsIParam n1 ty1) (HsIParam n2 ty2) - = n1 == n2 && eq_hsType env ty1 ty2 -eq_hsPred env _ _ = False -\end{code} diff --git a/ghc/compiler/ilxGen/IlxGen.lhs b/ghc/compiler/ilxGen/IlxGen.lhs index a4a7b7cb9a..2c0ea39478 100644 --- a/ghc/compiler/ilxGen/IlxGen.lhs +++ b/ghc/compiler/ilxGen/IlxGen.lhs @@ -16,7 +16,7 @@ import TyCon ( TyCon, tyConPrimRep, isUnboxedTupleTyCon, tyConDataCons, tyConTyVars, isDataTyCon, isAlgTyCon, tyConArity ) import Type ( liftedTypeKind, openTypeKind, unliftedTypeKind, - isUnLiftedType, isTyVarTy, mkTyVarTy, sourceTypeRep, + isUnLiftedType, isTyVarTy, mkTyVarTy, predTypeRep, splitForAllTys, splitFunTys, applyTy, applyTys, eqKind, tyVarsOfTypes ) import TypeRep ( Type(..) ) @@ -1119,7 +1119,6 @@ pushLit env (MachWord w) = text "ldc.i4" <+> integer w <+> text "conv.u4" pushLit env (MachWord64 w) = text "ldc.i8" <+> integer w <+> text "conv.u8" pushLit env (MachFloat f) = text "ldc.r4" <+> rational f pushLit env (MachDouble f) = text "ldc.r8" <+> rational f -pushLit env (MachLitLit _ _) = trace "WARNING: Cannot compile MachLitLit to ILX in IlxGen.lhs" (text "// MachLitLit!!! Not valid in ILX!!") pushLit env (MachNullAddr) = text "ldc.i4 0" pushLit env (MachLabel l _) = trace "WARNING: Cannot compile MachLabel to ILX in IlxGen.lhs" (text "// MachLabel!!! Not valid in ILX!!") @@ -1169,7 +1168,7 @@ deepIlxRepType ty@(TyConApp tc tys) deepIlxRepType (AppTy f x) = AppTy (deepIlxRepType f) (deepIlxRepType x) deepIlxRepType (ForAllTy b ty) = ForAllTy b (deepIlxRepType ty) deepIlxRepType (NoteTy _ ty) = deepIlxRepType ty -deepIlxRepType (SourceTy p) = deepIlxRepType (sourceTypeRep p) +deepIlxRepType (PredTy p) = deepIlxRepType (predTypeRep p) deepIlxRepType ty@(TyVarTy tv) = ty idIlxRepType id = deepIlxRepType (idType id) diff --git a/ghc/compiler/main/BinIface.hs b/ghc/compiler/main/BinIface.hs deleted file mode 100644 index c507f2e4dc..0000000000 --- a/ghc/compiler/main/BinIface.hs +++ /dev/null @@ -1,1051 +0,0 @@ -{-% DrIFT (Automatic class derivations for Haskell) v1.1 %-} -{-% DrIFT (Automatic class derivations for Haskell) v1.1 %-} --- --- (c) The University of Glasgow 2002 --- --- Binary interface file support. - -module BinIface ( writeBinIface, readBinIface, v_IgnoreHiVersion ) where - -#include "HsVersions.h" - -import HscTypes -import BasicTypes -import NewDemand -import HsTypes -import HsCore -import HsDecls -import HsBinds -import HsPat ( HsConDetails(..) ) -import TyCon -import Class -import VarEnv -import CostCentre -import RdrName ( mkRdrUnqual, mkRdrQual ) -import Name ( Name, nameOccName, nameModule_maybe ) -import NameEnv ( NameEnv, lookupNameEnv, nameEnvElts ) -import Module ( moduleName ) -import OccName ( OccName ) -import RnHsSyn -import DriverState ( v_Build_tag ) -import CmdLineOpts ( opt_HiVersion ) -import Panic -import SrcLoc -import Binary -import Util - -import DATA_IOREF -import EXCEPTION ( throwDyn ) -import Monad ( when ) - -#include "HsVersions.h" - --- --------------------------------------------------------------------------- --- We write out a ModIface, but read it in as a ParsedIface. --- There are some big differences, and some subtle ones. We do most --- of the conversion on the way out, so there is minimal fuss when we --- read it back in again (see RnMonad.lhs) - --- The main difference is that all Names in a ModIface are RdrNames in --- a ParsedIface, so when writing out a Name in binary we make sure it --- is binary-compatible with a RdrName. - --- Other subtle differences: --- - pi_mod is a ModuleName, but mi_mod is a Module. Hence we put --- Modules as ModuleNames. --- - pi_exports and pi_usages, Names have --- to be converted to OccNames. --- - pi_fixity is a NameEnv in ModIface, --- but a list of (Name,Fixity) pairs in ParsedIface. --- - versioning is totally different. --- - deprecations are different. - -writeBinIface :: FilePath -> ModIface -> IO () -writeBinIface hi_path mod_iface - = putBinFileWithDict hi_path (mi_module mod_iface) mod_iface - -readBinIface :: FilePath -> IO ParsedIface -readBinIface hi_path = getBinFileWithDict hi_path - - --- %********************************************************* --- %* * --- All the Binary instances --- %* * --- %********************************************************* - --- BasicTypes -{-! for IPName derive: Binary !-} -{-! for Fixity derive: Binary !-} -{-! for FixityDirection derive: Binary !-} -{-! for NewOrData derive: Binary !-} -{-! for Boxity derive: Binary !-} -{-! for StrictnessMark derive: Binary !-} -{-! for Activation derive: Binary !-} - -instance Binary Name where - -- we must print these as RdrNames, because that's how they will be read in - put_ bh name - = case nameModule_maybe name of - Just mod - | this_mod == mod -> put_ bh (mkRdrUnqual occ) - | otherwise -> put_ bh (mkRdrQual (moduleName mod) occ) - _ -> put_ bh (mkRdrUnqual occ) - where - occ = nameOccName name - (this_mod,_,_,_) = getUserData bh - - get bh = error "can't Binary.get a Name" - --- NewDemand -{-! for Demand derive: Binary !-} -{-! for Demands derive: Binary !-} -{-! for DmdResult derive: Binary !-} -{-! for StrictSig derive: Binary !-} - -instance Binary DmdType where - -- ignore DmdEnv when spitting out the DmdType - put bh (DmdType _ ds dr) = do p <- put bh ds; put bh dr; return (castBin p) - get bh = do ds <- get bh; dr <- get bh; return (DmdType emptyVarEnv ds dr) - --- TyCon -{-! for DataConDetails derive: Binary !-} - --- Class -{-! for DefMeth derive: Binary !-} - --- HsTypes -{-! for HsPred derive: Binary !-} -{-! for HsType derive: Binary !-} -{-! for HsTupCon derive: Binary !-} -{-! for HsTyVarBndr derive: Binary !-} - --- HsCore -{-! for UfExpr derive: Binary !-} -{-! for UfConAlt derive: Binary !-} -{-! for UfBinding derive: Binary !-} -{-! for UfBinder derive: Binary !-} -{-! for HsIdInfo derive: Binary !-} -{-! for UfNote derive: Binary !-} - --- HsDecls -{-! for ConDetails derive: Binary !-} -{-! for BangType derive: Binary !-} - -instance (Binary name) => Binary (TyClDecl name) where - put_ bh (IfaceSig name ty idinfo _) = do - putByte bh 0 - put_ bh name - lazyPut bh ty - lazyPut bh idinfo - put_ bh (ForeignType ae af ag ah) = - error "Binary.put_(TyClDecl): ForeignType" - put_ bh (TyData ai aj ak al am _ (Just generics) _) = do - putByte bh 2 - put_ bh ai - put_ bh aj - put_ bh ak - put_ bh al - put_ bh am - -- ignore Derivs - put_ bh generics -- Record whether generics needed or not - put_ bh (TySynonym aq ar as _) = do - putByte bh 3 - put_ bh aq - put_ bh ar - put_ bh as - put_ bh c@(ClassDecl ctxt nm tyvars fds sigs _ _) = do - putByte bh 4 - put_ bh ctxt - put_ bh nm - put_ bh tyvars - put_ bh fds - put_ bh sigs - -- ignore methods (there should be none) - -- ignore SrcLoc - get bh = do - h <- getByte bh - case h of - 0 -> do - name <- get bh - ty <- lazyGet bh - idinfo <- lazyGet bh - return (IfaceSig name ty idinfo noSrcLoc) - 1 -> error "Binary.get(TyClDecl): ForeignType" - 2 -> do - n_or_d <- get bh - ctx <- get bh - nm <- get bh - tyvars <- get bh - cons <- get bh - generics <- get bh - return (TyData n_or_d ctx nm tyvars cons - Nothing (Just generics) noSrcLoc) - 3 -> do - aq <- get bh - ar <- get bh - as <- get bh - return (TySynonym aq ar as noSrcLoc) - _ -> do - ctxt <- get bh - nm <- get bh - tyvars <- get bh - fds <- get bh - sigs <- get bh - return (ClassDecl ctxt nm tyvars fds sigs - Nothing noSrcLoc) - -instance (Binary name) => Binary (ConDecl name) where - put_ bh (ConDecl aa ac ad ae _) = do - put_ bh aa - put_ bh ac - put_ bh ad - put_ bh ae - -- ignore SrcLoc - get bh = do - aa <- get bh - ac <- get bh - ad <- get bh - ae <- get bh - return (ConDecl aa ac ad ae noSrcLoc) - -instance (Binary name) => Binary (InstDecl name) where - put_ bh (InstDecl aa _ _ ad _) = do - put_ bh aa - -- ignore MonoBinds - -- ignore Sigs - put_ bh ad - -- ignore SrcLoc - get bh = do - aa <- get bh - ad <- get bh - return (InstDecl aa EmptyMonoBinds [{-no sigs-}] ad noSrcLoc) - -instance (Binary name) => Binary (RuleDecl name) where - put_ bh (IfaceRule ag ah ai aj ak al _) = do - put_ bh ag - put_ bh ah - put_ bh ai - put_ bh aj - put_ bh ak - put_ bh al - -- ignore SrcLoc - get bh = do ag <- get bh - ah <- get bh - ai <- get bh - aj <- get bh - ak <- get bh - al <- get bh - return (IfaceRule ag ah ai aj ak al noSrcLoc) - -instance (Binary name) => Binary (DeprecDecl name) where - put_ bh (Deprecation aa ab _) = do - put_ bh aa - put_ bh ab - -- ignore SrcLoc - get bh = do - aa <- get bh - ab <- get bh - return (Deprecation aa ab noSrcLoc) - --- HsBinds -instance Binary name => Binary (Sig name) where - put_ bh (ClassOpSig n def ty _) = do put_ bh n; put_ bh def; put_ bh ty - get bh = do - n <- get bh - def <- get bh - ty <- get bh - return (ClassOpSig n def ty noSrcLoc) - --- CostCentre -{-! for IsCafCC derive: Binary !-} -{-! for IsDupdCC derive: Binary !-} -{-! for CostCentre derive: Binary !-} - - - -instance Binary ModIface where - put_ bh iface = do - build_tag <- readIORef v_Build_tag - put_ bh (show opt_HiVersion ++ build_tag) - p <- put_ bh (moduleName (mi_module iface)) - put_ bh (mi_package iface) - put_ bh (vers_module (mi_version iface)) - put_ bh (mi_orphan iface) - -- no: mi_boot - lazyPut bh (mi_deps iface) - lazyPut bh (map usageToOccName (mi_usages iface)) - put_ bh (vers_exports (mi_version iface), - map exportItemToRdrExportItem (mi_exports iface)) - put_ bh (declsToVersionedDecls (dcl_tycl (mi_decls iface)) - (vers_decls (mi_version iface))) - -- no: mi_globals - put_ bh (collectFixities (mi_fixities iface) - (dcl_tycl (mi_decls iface))) - put_ bh (dcl_insts (mi_decls iface)) - lazyPut bh (vers_rules (mi_version iface), dcl_rules (mi_decls iface)) - lazyPut bh (deprecsToIfaceDeprecs (mi_deprecs iface)) - - -- Read in as a ParsedIface, not a ModIface. See above. - get bh = error "Binary.get: ModIface" - -declsToVersionedDecls :: [RenamedTyClDecl] -> NameEnv Version - -> [(Version, RenamedTyClDecl)] -declsToVersionedDecls decls env - = map add_vers decls - where add_vers d = - case lookupNameEnv env (tyClDeclName d) of - Nothing -> (initialVersion, d) - Just v -> (v, d) - - ---NOT REALLY: deprecsToIfaceDeprecs :: Deprecations -> IfaceDeprecs -deprecsToIfaceDeprecs NoDeprecs = Nothing -deprecsToIfaceDeprecs (DeprecAll txt) = Just (Left txt) -deprecsToIfaceDeprecs (DeprecSome env) = Just (Right (nameEnvElts env)) - - -{-! for GenAvailInfo derive: Binary !-} -{-! for WhatsImported derive: Binary !-} - --- For binary interfaces we need to convert the ImportVersion Names to OccNames -usageToOccName :: Usage Name -> Usage OccName -usageToOccName usg - = usg { usg_entities = [ (nameOccName n, v) | (n,v) <- usg_entities usg ] } - -exportItemToRdrExportItem (mn, avails) - = (mn, map availInfoToRdrAvailInfo avails) - -availInfoToRdrAvailInfo :: AvailInfo -> RdrAvailInfo -availInfoToRdrAvailInfo (Avail n) - = Avail (nameOccName n) -availInfoToRdrAvailInfo (AvailTC n ns) - = AvailTC (nameOccName n) (map nameOccName ns) - --- --------------------------------------------------------------------------- --- Reading a binary interface into ParsedIface - -instance Binary ParsedIface where - put_ bh ParsedIface{ - pi_mod = module_name, - pi_pkg = pkg_name, - pi_vers = module_ver, - pi_orphan = orphan, - pi_usages = usages, - pi_exports = exports, - pi_decls = tycl_decls, - pi_fixity = fixities, - pi_insts = insts, - pi_rules = rules, - pi_deprecs = deprecs } = do - build_tag <- readIORef v_Build_tag - put_ bh (show opt_HiVersion ++ build_tag) - put_ bh module_name - put_ bh pkg_name - put_ bh module_ver - put_ bh orphan - lazyPut bh usages - put_ bh exports - put_ bh tycl_decls - put_ bh fixities - put_ bh insts - lazyPut bh rules - lazyPut bh deprecs - get bh = do - check_ver <- get bh - ignore_ver <- readIORef v_IgnoreHiVersion - build_tag <- readIORef v_Build_tag - let our_ver = show opt_HiVersion ++ build_tag - when (check_ver /= our_ver && not ignore_ver) $ - -- use userError because this will be caught by readIface - -- which will emit an error msg containing the iface module name. - throwDyn (ProgramError ( - "mismatched interface file versions: expected " - ++ our_ver ++ ", found " ++ check_ver)) - module_name <- get bh -- same rep. as Module, so that's ok - pkg_name <- get bh - module_ver <- get bh - orphan <- get bh - deps <- lazyGet bh - usages <- {-# SCC "bin_usages" #-} lazyGet bh - exports <- {-# SCC "bin_exports" #-} get bh - tycl_decls <- {-# SCC "bin_tycldecls" #-} get bh - fixities <- {-# SCC "bin_fixities" #-} get bh - insts <- {-# SCC "bin_insts" #-} get bh - rules <- {-# SCC "bin_rules" #-} lazyGet bh - deprecs <- {-# SCC "bin_deprecs" #-} lazyGet bh - return (ParsedIface { - pi_mod = module_name, - pi_pkg = pkg_name, - pi_vers = module_ver, - pi_orphan = orphan, - pi_deps = deps, - pi_usages = usages, - pi_exports = exports, - pi_decls = tycl_decls, - pi_fixity = fixities, - pi_insts = reverse insts, - pi_rules = rules, - pi_deprecs = deprecs }) - -GLOBAL_VAR(v_IgnoreHiVersion, False, Bool) - --- ---------------------------------------------------------------------------- -{-* Generated by DrIFT-v1.0 : Look, but Don't Touch. *-} - --- Imported from other files :- - -instance Binary Dependencies where - put_ bh deps = do put_ bh (dep_mods deps) - put_ bh (dep_pkgs deps) - put_ bh (dep_orphs deps) - - get bh = do ms <- get bh - ps <- get bh - os <- get bh - return (Deps { dep_mods = ms, dep_pkgs = ps, dep_orphs = os }) - -instance (Binary name) => Binary (GenAvailInfo name) where - put_ bh (Avail aa) = do - putByte bh 0 - put_ bh aa - put_ bh (AvailTC ab ac) = do - putByte bh 1 - put_ bh ab - put_ bh ac - get bh = do - h <- getByte bh - case h of - 0 -> do aa <- get bh - return (Avail aa) - _ -> do ab <- get bh - ac <- get bh - return (AvailTC ab ac) - -instance (Binary name) => Binary (Usage name) where - put_ bh usg = do - put_ bh (usg_name usg) - put_ bh (usg_mod usg) - put_ bh (usg_exports usg) - put_ bh (usg_entities usg) - put_ bh (usg_rules usg) - - get bh = do - nm <- get bh - mod <- get bh - exps <- get bh - ents <- get bh - rules <- get bh - return (Usage { usg_name = nm, usg_mod = mod, - usg_exports = exps, usg_entities = ents, - usg_rules = rules }) - -instance Binary Activation where - put_ bh NeverActive = do - putByte bh 0 - put_ bh AlwaysActive = do - putByte bh 1 - put_ bh (ActiveBefore aa) = do - putByte bh 2 - put_ bh aa - put_ bh (ActiveAfter ab) = do - putByte bh 3 - put_ bh ab - get bh = do - h <- getByte bh - case h of - 0 -> do return NeverActive - 1 -> do return AlwaysActive - 2 -> do aa <- get bh - return (ActiveBefore aa) - _ -> do ab <- get bh - return (ActiveAfter ab) - -instance Binary StrictnessMark where - put_ bh MarkedUserStrict = do - putByte bh 0 - put_ bh MarkedStrict = do - putByte bh 1 - put_ bh MarkedUnboxed = do - putByte bh 2 - put_ bh NotMarkedStrict = do - putByte bh 3 - get bh = do - h <- getByte bh - case h of - 0 -> do return MarkedUserStrict - 1 -> do return MarkedStrict - 2 -> do return MarkedUnboxed - _ -> do return NotMarkedStrict - -instance Binary Boxity where - put_ bh Boxed = do - putByte bh 0 - put_ bh Unboxed = do - putByte bh 1 - get bh = do - h <- getByte bh - case h of - 0 -> do return Boxed - _ -> do return Unboxed - -instance Binary NewOrData where - put_ bh NewType = do - putByte bh 0 - put_ bh DataType = do - putByte bh 1 - get bh = do - h <- getByte bh - case h of - 0 -> do return NewType - _ -> do return DataType - -instance Binary FixityDirection where - put_ bh InfixL = do - putByte bh 0 - put_ bh InfixR = do - putByte bh 1 - put_ bh InfixN = do - putByte bh 2 - get bh = do - h <- getByte bh - case h of - 0 -> do return InfixL - 1 -> do return InfixR - _ -> do return InfixN - -instance Binary Fixity where - put_ bh (Fixity aa ab) = do - put_ bh aa - put_ bh ab - get bh = do - aa <- get bh - ab <- get bh - return (Fixity aa ab) - -instance (Binary name) => Binary (FixitySig name) where - put_ bh (FixitySig aa ab _) = do - put_ bh aa - put_ bh ab - get bh = do - aa <- get bh - ab <- get bh - return (FixitySig aa ab noSrcLoc) - -instance (Binary name) => Binary (IPName name) where - put_ bh (Dupable aa) = do - putByte bh 0 - put_ bh aa - put_ bh (Linear ab) = do - putByte bh 1 - put_ bh ab - get bh = do - h <- getByte bh - case h of - 0 -> do aa <- get bh - return (Dupable aa) - _ -> do ab <- get bh - return (Linear ab) - -instance Binary Demand where - put_ bh Top = do - putByte bh 0 - put_ bh Abs = do - putByte bh 1 - put_ bh (Call aa) = do - putByte bh 2 - put_ bh aa - put_ bh (Eval ab) = do - putByte bh 3 - put_ bh ab - put_ bh (Defer ac) = do - putByte bh 4 - put_ bh ac - put_ bh (Box ad) = do - putByte bh 5 - put_ bh ad - put_ bh Bot = do - putByte bh 6 - get bh = do - h <- getByte bh - case h of - 0 -> do return Top - 1 -> do return Abs - 2 -> do aa <- get bh - return (Call aa) - 3 -> do ab <- get bh - return (Eval ab) - 4 -> do ac <- get bh - return (Defer ac) - 5 -> do ad <- get bh - return (Box ad) - _ -> do return Bot - -instance Binary Demands where - put_ bh (Poly aa) = do - putByte bh 0 - put_ bh aa - put_ bh (Prod ab) = do - putByte bh 1 - put_ bh ab - get bh = do - h <- getByte bh - case h of - 0 -> do aa <- get bh - return (Poly aa) - _ -> do ab <- get bh - return (Prod ab) - -instance Binary DmdResult where - put_ bh TopRes = do - putByte bh 0 - put_ bh RetCPR = do - putByte bh 1 - put_ bh BotRes = do - putByte bh 2 - get bh = do - h <- getByte bh - case h of - 0 -> do return TopRes - 1 -> do return RetCPR -- Really use RetCPR even if -fcpr-off - -- The wrapper was generated for CPR in - -- the imported module! - _ -> do return BotRes - -instance Binary StrictSig where - put_ bh (StrictSig aa) = do - put_ bh aa - get bh = do - aa <- get bh - return (StrictSig aa) - -instance (Binary name) => Binary (HsTyVarBndr name) where - put_ bh (UserTyVar aa) = do - putByte bh 0 - put_ bh aa - put_ bh (IfaceTyVar ab ac) = do - putByte bh 1 - put_ bh ab - put_ bh ac - get bh = do - h <- getByte bh - case h of - 0 -> do aa <- get bh - return (UserTyVar aa) - _ -> do ab <- get bh - ac <- get bh - return (IfaceTyVar ab ac) - -instance Binary HsTupCon where - put_ bh (HsTupCon ab ac) = do - put_ bh ab - put_ bh ac - get bh = do - ab <- get bh - ac <- get bh - return (HsTupCon ab ac) - -instance (Binary name) => Binary (HsTyOp name) where - put_ bh HsArrow = putByte bh 0 - put_ bh (HsTyOp n) = do putByte bh 1 - put_ bh n - - get bh = do h <- getByte bh - case h of - 0 -> return HsArrow - 1 -> do a <- get bh - return (HsTyOp a) - -instance (Binary name) => Binary (HsType name) where - put_ bh (HsForAllTy aa ab ac) = do - putByte bh 0 - put_ bh aa - put_ bh ab - put_ bh ac - put_ bh (HsTyVar ad) = do - putByte bh 1 - put_ bh ad - put_ bh (HsAppTy ae af) = do - putByte bh 2 - put_ bh ae - put_ bh af - put_ bh (HsFunTy ag ah) = do - putByte bh 3 - put_ bh ag - put_ bh ah - put_ bh (HsListTy ai) = do - putByte bh 4 - put_ bh ai - put_ bh (HsPArrTy aj) = do - putByte bh 5 - put_ bh aj - put_ bh (HsTupleTy ak al) = do - putByte bh 6 - put_ bh ak - put_ bh al - put_ bh (HsOpTy am an ao) = do - putByte bh 7 - put_ bh am - put_ bh an - put_ bh ao - put_ bh (HsNumTy ap) = do - putByte bh 8 - put_ bh ap - put_ bh (HsPredTy aq) = do - putByte bh 9 - put_ bh aq - put_ bh (HsKindSig ar as) = do - putByte bh 10 - put_ bh ar - put_ bh as - get bh = do - h <- getByte bh - case h of - 0 -> do aa <- get bh - ab <- get bh - ac <- get bh - return (HsForAllTy aa ab ac) - 1 -> do ad <- get bh - return (HsTyVar ad) - 2 -> do ae <- get bh - af <- get bh - return (HsAppTy ae af) - 3 -> do ag <- get bh - ah <- get bh - return (HsFunTy ag ah) - 4 -> do ai <- get bh - return (HsListTy ai) - 5 -> do aj <- get bh - return (HsPArrTy aj) - 6 -> do ak <- get bh - al <- get bh - return (HsTupleTy ak al) - 7 -> do am <- get bh - an <- get bh - ao <- get bh - return (HsOpTy am an ao) - 8 -> do ap <- get bh - return (HsNumTy ap) - 9 -> do aq <- get bh - return (HsPredTy aq) - _ -> do ar <- get bh - as <- get bh - return (HsKindSig ar as) - -instance (Binary name) => Binary (HsPred name) where - put_ bh (HsClassP aa ab) = do - putByte bh 0 - put_ bh aa - put_ bh ab - put_ bh (HsIParam ac ad) = do - putByte bh 1 - put_ bh ac - put_ bh ad - get bh = do - h <- getByte bh - case h of - 0 -> do aa <- get bh - ab <- get bh - return (HsClassP aa ab) - _ -> do ac <- get bh - ad <- get bh - return (HsIParam ac ad) - -instance (Binary name) => Binary (UfExpr name) where - put_ bh (UfVar aa) = do - putByte bh 0 - put_ bh aa - put_ bh (UfType ab) = do - putByte bh 1 - put_ bh ab - put_ bh (UfTuple ac ad) = do - putByte bh 2 - put_ bh ac - put_ bh ad - put_ bh (UfLam ae af) = do - putByte bh 3 - put_ bh ae - put_ bh af - put_ bh (UfApp ag ah) = do - putByte bh 4 - put_ bh ag - put_ bh ah - put_ bh (UfCase ai aj ak) = do - putByte bh 5 - put_ bh ai - put_ bh aj - put_ bh ak - put_ bh (UfLet al am) = do - putByte bh 6 - put_ bh al - put_ bh am - put_ bh (UfNote an ao) = do - putByte bh 7 - put_ bh an - put_ bh ao - put_ bh (UfLit ap) = do - putByte bh 8 - put_ bh ap - put_ bh (UfFCall as at) = do - putByte bh 9 - put_ bh as - put_ bh at - get bh = do - h <- getByte bh - case h of - 0 -> do aa <- get bh - return (UfVar aa) - 1 -> do ab <- get bh - return (UfType ab) - 2 -> do ac <- get bh - ad <- get bh - return (UfTuple ac ad) - 3 -> do ae <- get bh - af <- get bh - return (UfLam ae af) - 4 -> do ag <- get bh - ah <- get bh - return (UfApp ag ah) - 5 -> do ai <- get bh - aj <- get bh - ak <- get bh - return (UfCase ai aj ak) - 6 -> do al <- get bh - am <- get bh - return (UfLet al am) - 7 -> do an <- get bh - ao <- get bh - return (UfNote an ao) - 8 -> do ap <- get bh - return (UfLit ap) - _ -> do as <- get bh - at <- get bh - return (UfFCall as at) - -instance (Binary name) => Binary (UfConAlt name) where - put_ bh UfDefault = do - putByte bh 0 - put_ bh (UfDataAlt aa) = do - putByte bh 1 - put_ bh aa - put_ bh (UfTupleAlt ab) = do - putByte bh 2 - put_ bh ab - put_ bh (UfLitAlt ac) = do - putByte bh 3 - put_ bh ac - get bh = do - h <- getByte bh - case h of - 0 -> do return UfDefault - 1 -> do aa <- get bh - return (UfDataAlt aa) - 2 -> do ab <- get bh - return (UfTupleAlt ab) - _ -> do ac <- get bh - return (UfLitAlt ac) - -instance (Binary name) => Binary (UfBinding name) where - put_ bh (UfNonRec aa ab) = do - putByte bh 0 - put_ bh aa - put_ bh ab - put_ bh (UfRec ac) = do - putByte bh 1 - put_ bh ac - get bh = do - h <- getByte bh - case h of - 0 -> do aa <- get bh - ab <- get bh - return (UfNonRec aa ab) - _ -> do ac <- get bh - return (UfRec ac) - -instance (Binary name) => Binary (UfBinder name) where - put_ bh (UfValBinder aa ab) = do - putByte bh 0 - put_ bh aa - put_ bh ab - put_ bh (UfTyBinder ac ad) = do - putByte bh 1 - put_ bh ac - put_ bh ad - get bh = do - h <- getByte bh - case h of - 0 -> do aa <- get bh - ab <- get bh - return (UfValBinder aa ab) - _ -> do ac <- get bh - ad <- get bh - return (UfTyBinder ac ad) - -instance (Binary name) => Binary (HsIdInfo name) where - put_ bh (HsArity aa) = do - putByte bh 0 - put_ bh aa - put_ bh (HsStrictness ab) = do - putByte bh 1 - put_ bh ab - put_ bh (HsUnfold ac ad) = do - putByte bh 2 - put_ bh ac - put_ bh ad - put_ bh HsNoCafRefs = do - putByte bh 3 - put_ bh (HsWorker ae af) = do - putByte bh 4 - put_ bh ae - put_ bh af - get bh = do - h <- getByte bh - case h of - 0 -> do aa <- get bh - return (HsArity aa) - 1 -> do ab <- get bh - return (HsStrictness ab) - 2 -> do ac <- get bh - ad <- get bh - return (HsUnfold ac ad) - 3 -> do return HsNoCafRefs - _ -> do ae <- get bh - af <- get bh - return (HsWorker ae af) - -instance (Binary name) => Binary (UfNote name) where - put_ bh (UfSCC aa) = do - putByte bh 0 - put_ bh aa - put_ bh (UfCoerce ab) = do - putByte bh 1 - put_ bh ab - put_ bh UfInlineCall = do - putByte bh 2 - put_ bh UfInlineMe = do - putByte bh 3 - put_ bh (UfCoreNote s) = do - putByte bh 4 - put_ bh s - get bh = do - h <- getByte bh - case h of - 0 -> do aa <- get bh - return (UfSCC aa) - 1 -> do ab <- get bh - return (UfCoerce ab) - 2 -> do return UfInlineCall - 3 -> do return UfInlineMe - _ -> do ac <- get bh - return (UfCoreNote ac) - -instance (Binary name) => Binary (BangType name) where - put_ bh (BangType aa ab) = do - put_ bh aa - put_ bh ab - get bh = do - aa <- get bh - ab <- get bh - return (BangType aa ab) - -instance (Binary name, Binary arg) => Binary (HsConDetails name arg) where - put_ bh (PrefixCon aa) = do - putByte bh 0 - put_ bh aa - put_ bh (InfixCon ab ac) = do - putByte bh 1 - put_ bh ab - put_ bh ac - put_ bh (RecCon ad) = do - putByte bh 2 - put_ bh ad - get bh = do - h <- getByte bh - case h of - 0 -> do aa <- get bh - return (PrefixCon aa) - 1 -> do ab <- get bh - ac <- get bh - return (InfixCon ab ac) - _ -> do ad <- get bh - return (RecCon ad) - -instance (Binary datacon) => Binary (DataConDetails datacon) where - put_ bh (DataCons aa) = do - putByte bh 0 - put_ bh aa - put_ bh Unknown = do - putByte bh 1 - put_ bh (HasCons ab) = do - putByte bh 2 - put_ bh ab - get bh = do - h <- getByte bh - case h of - 0 -> do aa <- get bh - return (DataCons aa) - 1 -> do return Unknown - _ -> do ab <- get bh - return (HasCons ab) - -instance (Binary id) => Binary (DefMeth id) where - put_ bh NoDefMeth = do - putByte bh 0 - put_ bh (DefMeth aa) = do - putByte bh 1 - put_ bh aa - put_ bh GenDefMeth = do - putByte bh 2 - get bh = do - h <- getByte bh - case h of - 0 -> do return NoDefMeth - 1 -> do aa <- get bh - return (DefMeth aa) - _ -> do return GenDefMeth - -instance Binary IsCafCC where - put_ bh CafCC = do - putByte bh 0 - put_ bh NotCafCC = do - putByte bh 1 - get bh = do - h <- getByte bh - case h of - 0 -> do return CafCC - _ -> do return NotCafCC - -instance Binary IsDupdCC where - put_ bh OriginalCC = do - putByte bh 0 - put_ bh DupdCC = do - putByte bh 1 - get bh = do - h <- getByte bh - case h of - 0 -> do return OriginalCC - _ -> do return DupdCC - -instance Binary CostCentre where - put_ bh NoCostCentre = do - putByte bh 0 - put_ bh (NormalCC aa ab ac ad) = do - putByte bh 1 - put_ bh aa - put_ bh ab - put_ bh ac - put_ bh ad - put_ bh (AllCafsCC ae) = do - putByte bh 2 - put_ bh ae - get bh = do - h <- getByte bh - case h of - 0 -> do return NoCostCentre - 1 -> do aa <- get bh - ab <- get bh - ac <- get bh - ad <- get bh - return (NormalCC aa ab ac ad) - _ -> do ae <- get bh - return (AllCafsCC ae) diff --git a/ghc/compiler/main/CmdLineOpts.lhs b/ghc/compiler/main/CmdLineOpts.lhs index 153c058c02..7a4799bc5b 100644 --- a/ghc/compiler/main/CmdLineOpts.lhs +++ b/ghc/compiler/main/CmdLineOpts.lhs @@ -246,6 +246,7 @@ data DynFlag | Opt_D_dump_stix | Opt_D_dump_simpl_stats | Opt_D_dump_tc_trace + | Opt_D_dump_if_trace | Opt_D_dump_splices | Opt_D_dump_BCOs | Opt_D_dump_vect diff --git a/ghc/compiler/main/DriverFlags.hs b/ghc/compiler/main/DriverFlags.hs index 28bb2857a9..701f2ba586 100644 --- a/ghc/compiler/main/DriverFlags.hs +++ b/ghc/compiler/main/DriverFlags.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- $Id: DriverFlags.hs,v 1.126 2003/09/24 13:04:50 simonmar Exp $ +-- $Id: DriverFlags.hs,v 1.127 2003/10/09 11:58:56 simonpj Exp $ -- -- Driver flags -- @@ -371,6 +371,7 @@ dynamic_flags = [ , ( "ddump-worker-wrapper", NoArg (setDynFlag Opt_D_dump_worker_wrapper) ) , ( "dshow-passes", NoArg (setVerbosity "2") ) , ( "ddump-rn-trace", NoArg (setDynFlag Opt_D_dump_rn_trace) ) + , ( "ddump-if-trace", NoArg (setDynFlag Opt_D_dump_if_trace) ) , ( "ddump-tc-trace", NoArg (setDynFlag Opt_D_dump_tc_trace) ) , ( "ddump-splices", NoArg (setDynFlag Opt_D_dump_splices) ) , ( "ddump-rn-stats", NoArg (setDynFlag Opt_D_dump_rn_stats) ) diff --git a/ghc/compiler/main/DriverPipeline.hs b/ghc/compiler/main/DriverPipeline.hs index 87977cb1f7..e889a72845 100644 --- a/ghc/compiler/main/DriverPipeline.hs +++ b/ghc/compiler/main/DriverPipeline.hs @@ -41,6 +41,7 @@ import Module import ErrUtils import CmdLineOpts import Config +import RdrName ( GlobalRdrEnv ) import Panic import Util import BasicTypes ( SuccessFlag(..) ) @@ -95,29 +96,29 @@ preprocess filename = -- NB. No old interface can also mean that the source has changed. -compile :: GhciMode -- distinguish batch from interactive +compile :: HscEnv -> Module -> ModLocation -> Bool -- True <=> source unchanged -> Bool -- True <=> have object -> Maybe ModIface -- old interface, if available - -> HomePackageTable -- For home-module stuff - -> PersistentCompilerState -- persistent compiler state -> IO CompResult data CompResult - = CompOK PersistentCompilerState -- Updated PCS - ModDetails -- New details + = CompOK ModDetails -- New details + (Maybe GlobalRdrEnv) -- Lexical environment for the module + -- (Maybe because we may have loaded it from + -- its precompiled interface) ModIface -- New iface (Maybe Linkable) -- New code; Nothing => compilation was not reqd -- (old code is still valid) - | CompErrs PersistentCompilerState -- Updated PCS + | CompErrs -compile ghci_mode this_mod location +compile hsc_env this_mod location source_unchanged have_object - old_iface hpt pcs = do + old_iface = do dyn_flags <- restoreDynFlags -- Restore to the state of the last save @@ -154,20 +155,18 @@ compile ghci_mode this_mod location -- -no-recomp should also work with --make do_recomp <- readIORef v_Recomp let source_unchanged' = source_unchanged && do_recomp - hsc_env = HscEnv { hsc_mode = ghci_mode, - hsc_dflags = dyn_flags', - hsc_HPT = hpt } + hsc_env' = hsc_env { hsc_dflags = dyn_flags' } -- run the compiler - hsc_result <- hscMain hsc_env pcs this_mod location + hsc_result <- hscMain hsc_env' this_mod location source_unchanged' have_object old_iface case hsc_result of - HscFail pcs -> return (CompErrs pcs) + HscFail -> return CompErrs - HscNoRecomp pcs details iface -> return (CompOK pcs details iface Nothing) + HscNoRecomp details iface -> return (CompOK details Nothing iface Nothing) - HscRecomp pcs details iface + HscRecomp details rdr_env iface stub_h_exists stub_c_exists maybe_interpreted_code -> do let maybe_stub_o <- compileStub dyn_flags' stub_c_exists @@ -202,7 +201,7 @@ compile ghci_mode this_mod location let linkable = LM unlinked_time mod_name (hs_unlinked ++ stub_unlinked) - return (CompOK pcs details iface (Just linkable)) + return (CompOK details rdr_env iface (Just linkable)) ----------------------------------------------------------------------------- -- stub .h and .c files (for foreign export support) @@ -620,14 +619,10 @@ runPhase Hsc basename suff input_fn get_output_fn _maybe_loc = do hscStubCOutName = basename ++ "_stub.c", hscStubHOutName = basename ++ "_stub.h", extCoreName = basename ++ ".hcr" } - hsc_env = HscEnv { hsc_mode = OneShot, - hsc_dflags = dyn_flags', - hsc_HPT = emptyHomePackageTable } - + hsc_env <- newHscEnv OneShot dyn_flags' -- run the compiler! - pcs <- initPersistentCompilerState - result <- hscMain hsc_env pcs mod + result <- hscMain hsc_env mod location{ ml_hspp_file=Just input_fn } source_unchanged False @@ -635,13 +630,14 @@ runPhase Hsc basename suff input_fn get_output_fn _maybe_loc = do case result of - HscFail pcs -> throwDyn (PhaseFailed "hsc" (ExitFailure 1)) + HscFail -> throwDyn (PhaseFailed "hsc" (ExitFailure 1)) - HscNoRecomp pcs details iface -> do + HscNoRecomp details iface -> do SysTools.touch "Touching object file" o_file return (Nothing, Just location, output_fn) - HscRecomp _pcs _details _iface stub_h_exists stub_c_exists + HscRecomp _details _rdr_env _iface + stub_h_exists stub_c_exists _maybe_interpreted_code -> do -- deal with stubs diff --git a/ghc/compiler/main/HscMain.lhs b/ghc/compiler/main/HscMain.lhs index 9b42afcc60..4de831c58c 100644 --- a/ghc/compiler/main/HscMain.lhs +++ b/ghc/compiler/main/HscMain.lhs @@ -6,7 +6,7 @@ \begin{code} module HscMain ( - HscResult(..), hscMain, initPersistentCompilerState + HscResult(..), hscMain, newHscEnv #ifdef GHCI , hscStmt, hscTcExpr, hscThing, , compileExpr @@ -16,7 +16,9 @@ module HscMain ( #include "HsVersions.h" #ifdef GHCI +import HsSyn ( Stmt(..) ) import TcHsSyn ( TypecheckedHsExpr ) +import IfaceSyn ( IfaceDecl ) import CodeOutput ( outputForeignStubs ) import ByteCodeGen ( byteCodeGen, coreExprToBCOs ) import Linker ( HValue, linkExpr ) @@ -25,51 +27,49 @@ import CorePrep ( corePrepExpr ) import Flattening ( flattenExpr ) import TcRnDriver ( tcRnStmt, tcRnExpr, tcRnThing ) import RdrHsSyn ( RdrNameStmt ) +import RdrName ( GlobalRdrEnv ) import Type ( Type ) import PrelNames ( iNTERACTIVE ) import StringBuffer ( stringToStringBuffer ) import SrcLoc ( noSrcLoc ) import Name ( Name ) import CoreLint ( lintUnfolding ) +import DsMeta ( templateHaskellNames ) +import BasicTypes ( Fixity ) #endif -import HsSyn - -import RdrName ( nameRdrName ) import StringBuffer ( hGetStringBuffer ) import Parser import Lexer ( P(..), ParseResult(..), mkPState, showPFailed ) import SrcLoc ( mkSrcLoc ) -import TcRnDriver ( checkOldIface, tcRnModule, tcRnExtCore, tcRnIface ) -import RnEnv ( extendOrigNameCache ) -import PrelInfo ( wiredInThingEnv, knownKeyNames ) -import PrelRules ( builtinRules ) -import MkIface ( mkIface ) +import TcRnDriver ( tcRnModule, tcRnExtCore, tcRnIface ) +import IfaceEnv ( initNameCache ) +import LoadIface ( ifaceStats, initExternalPackageState ) +import PrelInfo ( wiredInThings, basicKnownKeyNames ) +import RdrName ( GlobalRdrEnv ) +import MkIface ( checkOldIface, mkIface ) import Desugar import Flattening ( flatten ) import SimplCore import TidyPgm ( tidyCorePgm ) import CorePrep ( corePrepPgm ) import CoreToStg ( coreToStg ) +import Name ( Name, NamedThing(..) ) import SimplStg ( stg2stg ) import CodeGen ( codeGen ) import CodeOutput ( codeOutput ) -import Module ( emptyModuleEnv ) import CmdLineOpts import DriverPhases ( isExtCore_file ) -import ErrUtils ( dumpIfSet_dyn, showPass ) +import ErrUtils ( dumpIfSet, dumpIfSet_dyn, showPass ) import UniqSupply ( mkSplitUniqSupply ) -import Bag ( consBag, emptyBag ) import Outputable import HscStats ( ppSourceStats ) import HscTypes import MkExternalCore ( emitExternalCore ) import ParserCore import ParserCoreUtils -import FiniteMap ( emptyFM ) -import Name ( nameModule ) import Module ( Module, ModLocation(..), showModMsg ) import FastString import Maybes ( expectJust ) @@ -77,27 +77,58 @@ import Maybes ( expectJust ) import Monad ( when ) import Maybe ( isJust, fromJust ) import IO +import DATA_IOREF ( newIORef, readIORef ) \end{code} %************************************************************************ %* * -\subsection{The main compiler pipeline} + Initialisation +%* * +%************************************************************************ + +\begin{code} +newHscEnv :: GhciMode -> DynFlags -> IO HscEnv +newHscEnv ghci_mode dflags + = do { eps_var <- newIORef initExternalPackageState + ; us <- mkSplitUniqSupply 'r' + ; nc_var <- newIORef (initNameCache us knownKeyNames) + ; return (HscEnv { hsc_mode = ghci_mode, + hsc_dflags = dflags, + hsc_HPT = emptyHomePackageTable, + hsc_EPS = eps_var, + hsc_NC = nc_var } ) } + + +knownKeyNames :: [Name] -- Put here to avoid loops involving DsMeta, + -- where templateHaskellNames are defined +knownKeyNames = map getName wiredInThings + ++ basicKnownKeyNames +#ifdef GHCI + ++ templateHaskellNames +#endif +\end{code} + + +%************************************************************************ +%* * + The main compiler pipeline %* * %************************************************************************ \begin{code} data HscResult - -- compilation failed - = HscFail PersistentCompilerState -- updated PCS - -- concluded that it wasn't necessary - | HscNoRecomp PersistentCompilerState -- updated PCS - ModDetails -- new details (HomeSymbolTable additions) + -- Compilation failed + = HscFail + + -- Concluded that it wasn't necessary + | HscNoRecomp ModDetails -- new details (HomeSymbolTable additions) ModIface -- new iface (if any compilation was done) - -- did recompilation - | HscRecomp PersistentCompilerState -- updated PCS - ModDetails -- new details (HomeSymbolTable additions) - ModIface -- new iface (if any compilation was done) + + -- Did recompilation + | HscRecomp ModDetails -- new details (HomeSymbolTable additions) + (Maybe GlobalRdrEnv) + ModIface -- new iface (if any compilation was done) Bool -- stub_h exists Bool -- stub_c exists (Maybe CompiledByteCode) @@ -107,7 +138,6 @@ data HscResult hscMain :: HscEnv - -> PersistentCompilerState -- IN: persistent compiler state -> Module -> ModLocation -- location info -> Bool -- True <=> source unchanged @@ -115,35 +145,35 @@ hscMain -> Maybe ModIface -- old interface, if available -> IO HscResult -hscMain hsc_env pcs mod location +hscMain hsc_env mod location source_unchanged have_object maybe_old_iface = do { - (pcs_ch, maybe_chk_result) <- _scc_ "checkOldIface" - checkOldIface hsc_env pcs mod - (ml_hi_file location) - source_unchanged maybe_old_iface; - case maybe_chk_result of { - Nothing -> return (HscFail pcs_ch) ; - Just (recomp_reqd, maybe_checked_iface) -> do { + (recomp_reqd, maybe_checked_iface) <- + _scc_ "checkOldIface" + checkOldIface hsc_env mod + (ml_hi_file location) + source_unchanged maybe_old_iface; let no_old_iface = not (isJust maybe_checked_iface) what_next | recomp_reqd || no_old_iface = hscRecomp | otherwise = hscNoRecomp - ; what_next hsc_env pcs_ch have_object + ; what_next hsc_env have_object mod location maybe_checked_iface - }}} + } -- hscNoRecomp definitely expects to have the old interface available -hscNoRecomp hsc_env pcs_ch have_object +hscNoRecomp hsc_env have_object mod location (Just old_iface) | hsc_mode hsc_env == OneShot = do { when (verbosity (hsc_dflags hsc_env) > 0) $ hPutStrLn stderr "compilation IS NOT required"; + dumpIfaceStats hsc_env ; + let { bomb = panic "hscNoRecomp:OneShot" }; - return (HscNoRecomp pcs_ch bomb bomb) + return (HscNoRecomp bomb bomb) } | otherwise = do { @@ -151,18 +181,14 @@ hscNoRecomp hsc_env pcs_ch have_object hPutStrLn stderr ("Skipping " ++ showModMsg have_object mod location); - -- Typecheck - (pcs_tc, maybe_tc_result) <- _scc_ "tcRnIface" - tcRnIface hsc_env pcs_ch old_iface ; - - case maybe_tc_result of { - Nothing -> return (HscFail pcs_tc); - Just new_details -> + new_details <- _scc_ "tcRnIface" + tcRnIface hsc_env old_iface ; + dumpIfaceStats hsc_env ; - return (HscNoRecomp pcs_tc new_details old_iface) - }} + return (HscNoRecomp new_details old_iface) + } -hscRecomp hsc_env pcs_ch have_object +hscRecomp hsc_env have_object mod location maybe_checked_iface = do { -- what target are we shooting for? @@ -177,13 +203,13 @@ hscRecomp hsc_env pcs_ch have_object showModMsg (not toInterp) mod location); ; front_res <- if toCore then - hscCoreFrontEnd hsc_env pcs_ch location + hscCoreFrontEnd hsc_env location else - hscFrontEnd hsc_env pcs_ch location + hscFrontEnd hsc_env location ; case front_res of Left flure -> return flure; - Right (pcs_tc, ds_result) -> do { + Right ds_result -> do { -- OMITTED: @@ -193,11 +219,15 @@ hscRecomp hsc_env pcs_ch have_object -- FLATTENING ------------------- ; flat_result <- _scc_ "Flattening" - flatten hsc_env pcs_tc ds_result + flatten hsc_env ds_result + +{- TEMP: need to review space-leak fixing here + NB: even the code generator can force one of the + thunks for constructor arguments, for newtypes in particular ; let -- Rule-base accumulated from imported packages - pkg_rule_base = eps_rule_base (pcs_EPS pcs_tc) + pkg_rule_base = eps_rule_base (hsc_EPS hsc_env) -- In one-shot mode, ZAP the external package state at -- this point, because we aren't going to need it from @@ -208,6 +238,7 @@ hscRecomp hsc_env pcs_ch have_object | otherwise = pcs_tc ; pkg_rule_base `seq` pcs_middle `seq` return () +-} -- alive at this point: -- pcs_middle @@ -217,21 +248,16 @@ hscRecomp hsc_env pcs_ch have_object ------------------- -- SIMPLIFY ------------------- - ; simpl_result <- _scc_ "Core2Core" - core2core hsc_env pkg_rule_base flat_result + ; simpl_result <- _scc_ "Core2Core" + core2core hsc_env flat_result ------------------- -- TIDY ------------------- - ; (pcs_simpl, tidy_result) - <- _scc_ "CoreTidy" - tidyCorePgm dflags pcs_middle simpl_result - - -- ZAP the persistent compiler state altogether now if we're - -- in one-shot mode, to save space. - ; pcs_final <- if one_shot then return (error "pcs_final missing") - else return pcs_simpl + ; tidy_result <- _scc_ "CoreTidy" + tidyCorePgm hsc_env simpl_result + -- Emit external core ; emitExternalCore dflags tidy_result -- Alive at this point: @@ -255,6 +281,9 @@ hscRecomp hsc_env pcs_ch have_object ; final_iface <- if one_shot then return (error "no final iface") else return new_iface + ; let { final_globals | one_shot = Nothing + | otherwise = Just $! (mg_rdr_env tidy_result) } + ; final_globals `seq` return () -- Build the final ModDetails (except in one-shot mode, where -- we won't need this information after compilation). @@ -270,36 +299,38 @@ hscRecomp hsc_env pcs_ch have_object ; (stub_h_exists, stub_c_exists, maybe_bcos) <- hscBackEnd dflags tidy_result - -- and the answer is ... - ; return (HscRecomp pcs_final - final_details + -- And the answer is ... + ; dumpIfaceStats hsc_env + + ; return (HscRecomp final_details + final_globals final_iface stub_h_exists stub_c_exists maybe_bcos) }} -hscCoreFrontEnd hsc_env pcs_ch location = do { +hscCoreFrontEnd hsc_env location = do { ------------------- -- PARSE ------------------- ; inp <- readFile (expectJust "hscCoreFrontEnd:hspp" (ml_hspp_file location)) ; case parseCore inp 1 of - FailP s -> hPutStrLn stderr s >> return (Left (HscFail pcs_ch)); + FailP s -> hPutStrLn stderr s >> return (Left HscFail); OkP rdr_module -> do { ------------------- -- RENAME and TYPECHECK ------------------- - ; (pcs_tc, maybe_tc_result) <- _scc_ "TypeCheck" - tcRnExtCore hsc_env pcs_ch rdr_module + ; maybe_tc_result <- _scc_ "TypeCheck" + tcRnExtCore hsc_env rdr_module ; case maybe_tc_result of { - Nothing -> return (Left (HscFail pcs_tc)); - Just mod_guts -> return (Right (pcs_tc, mod_guts)) + Nothing -> return (Left HscFail); + Just mod_guts -> return (Right mod_guts) -- No desugaring to do! }}} -hscFrontEnd hsc_env pcs_ch location = do { +hscFrontEnd hsc_env location = do { ------------------- -- PARSE ------------------- @@ -307,26 +338,26 @@ hscFrontEnd hsc_env pcs_ch location = do { (expectJust "hscFrontEnd:hspp" (ml_hspp_file location)) ; case maybe_parsed of { - Nothing -> return (Left (HscFail pcs_ch)); + Nothing -> return (Left HscFail); Just rdr_module -> do { ------------------- -- RENAME and TYPECHECK ------------------- - ; (pcs_tc, maybe_tc_result) <- _scc_ "Typecheck-Rename" - tcRnModule hsc_env pcs_ch rdr_module + ; maybe_tc_result <- _scc_ "Typecheck-Rename" + tcRnModule hsc_env rdr_module ; case maybe_tc_result of { - Nothing -> return (Left (HscFail pcs_ch)); + Nothing -> return (Left HscFail); Just tc_result -> do { ------------------- -- DESUGAR ------------------- ; maybe_ds_result <- _scc_ "DeSugar" - deSugar hsc_env pcs_tc tc_result + deSugar hsc_env tc_result ; case maybe_ds_result of - Nothing -> return (Left (HscFail pcs_ch)); - Just ds_result -> return (Right (pcs_tc, ds_result)); + Nothing -> return (Left HscFail); + Just ds_result -> return (Right ds_result); }}}}} @@ -393,7 +424,7 @@ myParseModule dflags src_filename case unP parseModule (mkPState buf loc dflags) of { - PFailed l1 l2 err -> do { hPutStrLn stderr (showPFailed l1 l2 err); + PFailed l1 l2 err -> do { hPutStrLn stderr (showSDoc (showPFailed l1 l2 err)); return Nothing }; POk _ rdr_module -> do { @@ -456,50 +487,47 @@ A naked expression returns a singleton Name [it]. #ifdef GHCI hscStmt -- Compile a stmt all the way to an HValue, but don't run it :: HscEnv - -> PersistentCompilerState -- IN: persistent compiler state -> InteractiveContext -- Context for compiling -> String -- The statement - -> IO ( PersistentCompilerState, - Maybe (InteractiveContext, [Name], HValue) ) + -> IO (Maybe (InteractiveContext, [Name], HValue)) -hscStmt hsc_env pcs icontext stmt +hscStmt hsc_env icontext stmt = do { maybe_stmt <- hscParseStmt (hsc_dflags hsc_env) stmt ; case maybe_stmt of { - Nothing -> return (pcs, Nothing) ; + Nothing -> return Nothing ; Just parsed_stmt -> do { -- Rename and typecheck it - (pcs1, maybe_tc_result) - <- tcRnStmt hsc_env pcs icontext parsed_stmt + maybe_tc_result + <- tcRnStmt hsc_env icontext parsed_stmt ; case maybe_tc_result of { - Nothing -> return (pcs1, Nothing) ; + Nothing -> return Nothing ; Just (new_ic, bound_names, tc_expr) -> do { -- Then desugar, code gen, and link it - ; hval <- compileExpr hsc_env pcs1 iNTERACTIVE + ; hval <- compileExpr hsc_env iNTERACTIVE (ic_rn_gbl_env new_ic) (ic_type_env new_ic) tc_expr - ; return (pcs1, Just (new_ic, bound_names, hval)) + ; return (Just (new_ic, bound_names, hval)) }}}}} hscTcExpr -- Typecheck an expression (but don't run it) :: HscEnv - -> PersistentCompilerState -- IN: persistent compiler state -> InteractiveContext -- Context for compiling -> String -- The expression - -> IO (PersistentCompilerState, Maybe Type) + -> IO (Maybe Type) -hscTcExpr hsc_env pcs icontext expr +hscTcExpr hsc_env icontext expr = do { maybe_stmt <- hscParseStmt (hsc_dflags hsc_env) expr ; case maybe_stmt of { Just (ExprStmt expr _ _) - -> tcRnExpr hsc_env pcs icontext expr ; + -> tcRnExpr hsc_env icontext expr ; Just other -> do { hPutStrLn stderr ("not an expression: `" ++ expr ++ "'") ; - return (pcs, Nothing) } ; - Nothing -> return (pcs, Nothing) } } + return Nothing } ; + Nothing -> return Nothing } } \end{code} \begin{code} @@ -514,7 +542,7 @@ hscParseStmt dflags str case unP parseStmt (mkPState buf loc dflags) of { - PFailed l1 l2 err -> do { hPutStrLn stderr (showPFailed l1 l2 err); + PFailed l1 l2 err -> do { hPutStrLn stderr (showSDoc (showPFailed l1 l2 err)); return Nothing }; -- no stmt: the line consisted of just space or comments @@ -540,26 +568,21 @@ hscParseStmt dflags str #ifdef GHCI hscThing -- like hscStmt, but deals with a single identifier :: HscEnv - -> PersistentCompilerState -- IN: persistent compiler state -> InteractiveContext -- Context for compiling -> String -- The identifier - -> IO ( PersistentCompilerState, - [TyThing] ) - -hscThing hsc_env pcs0 ic str - = do let dflags = hsc_dflags hsc_env + -> IO [(IfaceDecl, Fixity)] - maybe_rdr_name <- myParseIdentifier dflags str +hscThing hsc_env ic str + = do maybe_rdr_name <- myParseIdentifier (hsc_dflags hsc_env) str case maybe_rdr_name of { - Nothing -> return (pcs0, []); + Nothing -> return []; Just rdr_name -> do - (pcs1, maybe_tc_result) <- - tcRnThing hsc_env pcs0 ic rdr_name + maybe_tc_result <- tcRnThing hsc_env ic rdr_name case maybe_tc_result of { - Nothing -> return (pcs1, []) ; - Just things -> return (pcs1, things) + Nothing -> return [] ; + Just things -> return things }} myParseIdentifier dflags str @@ -568,7 +591,7 @@ myParseIdentifier dflags str let loc = mkSrcLoc FSLIT("<interactive>") 1 0 case unP parseIdentifier (mkPState buf loc dflags) of - PFailed l1 l2 err -> do { hPutStrLn stderr (showPFailed l1 l2 err); + PFailed l1 l2 err -> do { hPutStrLn stderr (showSDoc (showPFailed l1 l2 err)); return Nothing } POk _ rdr_name -> return (Just rdr_name) @@ -584,20 +607,19 @@ myParseIdentifier dflags str \begin{code} #ifdef GHCI compileExpr :: HscEnv - -> PersistentCompilerState -> Module -> GlobalRdrEnv -> TypeEnv -> TypecheckedHsExpr -> IO HValue -compileExpr hsc_env pcs this_mod rdr_env type_env tc_expr +compileExpr hsc_env this_mod rdr_env type_env tc_expr = do { let { dflags = hsc_dflags hsc_env ; lint_on = dopt Opt_DoCoreLinting dflags } -- Desugar it - ; ds_expr <- deSugarExpr hsc_env pcs this_mod rdr_env type_env tc_expr + ; ds_expr <- deSugarExpr hsc_env this_mod rdr_env type_env tc_expr -- Flatten it - ; flat_expr <- flattenExpr hsc_env pcs ds_expr + ; flat_expr <- flattenExpr hsc_env ds_expr -- Simplify it ; simpl_expr <- simplifyExpr dflags flat_expr @@ -621,7 +643,7 @@ compileExpr hsc_env pcs this_mod rdr_env type_env tc_expr ; bcos <- coreExprToBCOs dflags prepd_expr -- link it - ; hval <- linkExpr hsc_env pcs bcos + ; hval <- linkExpr hsc_env bcos ; return hval } @@ -631,40 +653,19 @@ compileExpr hsc_env pcs this_mod rdr_env type_env tc_expr %************************************************************************ %* * -\subsection{Initial persistent state} + Statistics on reading interfaces %* * %************************************************************************ \begin{code} -initPersistentCompilerState :: IO PersistentCompilerState -initPersistentCompilerState - = do nc <- initNameCache - return ( - PCS { pcs_EPS = initExternalPackageState, - pcs_nc = nc }) - -initNameCache :: IO NameCache - = do us <- mkSplitUniqSupply 'r' - return (NameCache { nsUniqs = us, - nsNames = initOrigNames, - nsIPs = emptyFM }) - -initExternalPackageState :: ExternalPackageState -initExternalPackageState - = emptyExternalPackageState { - eps_rules = foldr add_rule (emptyBag, 0) builtinRules, - eps_PTE = wiredInThingEnv, - } +dumpIfaceStats :: HscEnv -> IO () +dumpIfaceStats hsc_env + = do { eps <- readIORef (hsc_EPS hsc_env) + ; dumpIfSet (dump_if_trace || dump_rn_stats) + "Interface statistics" + (ifaceStats eps) } where - add_rule (name,rule) (rules, n_slurped) - = (gated_decl `consBag` rules, n_slurped) - where - gated_decl = (gate_fn, (mod, IfaceRuleOut rdr_name rule)) - mod = nameModule name - rdr_name = nameRdrName name -- Seems a bit of a hack to go back - -- to the RdrName - gate_fn vis_fn = vis_fn name -- Load the rule whenever name is visible - -initOrigNames :: OrigNameCache -initOrigNames = foldl extendOrigNameCache emptyModuleEnv knownKeyNames + dflags = hsc_dflags hsc_env + dump_rn_stats = dopt Opt_D_dump_rn_stats dflags + dump_if_trace = dopt Opt_D_dump_if_trace dflags \end{code} diff --git a/ghc/compiler/main/HscStats.lhs b/ghc/compiler/main/HscStats.lhs index 8e59f3c16f..e830170f58 100644 --- a/ghc/compiler/main/HscStats.lhs +++ b/ghc/compiler/main/HscStats.lhs @@ -9,7 +9,6 @@ module HscStats ( ppSourceStats ) where #include "HsVersions.h" import HsSyn -import TyCon ( DataConDetails(..) ) import Outputable import Char ( isSpace ) import Util ( count ) @@ -64,13 +63,13 @@ ppSourceStats short (HsModule _ exports imports decls _ src_loc) trim ls = takeWhile (not.isSpace) (dropWhile isSpace ls) - (fixity_sigs, bind_tys, _, bind_specs, bind_inlines) + (fixity_sigs, bind_tys, bind_specs, bind_inlines) = count_sigs [d | SigD d <- decls] -- NB: this omits fixity decls on local bindings and -- in class decls. ToDo tycl_decls = [d | TyClD d <- decls] - (class_ds, data_ds, newt_ds, type_ds, _) = countTyClDecls tycl_decls + (class_ds, type_ds, data_ds, newt_ds) = countTyClDecls tycl_decls inst_decls = [d | InstD d <- decls] inst_ds = length inst_decls @@ -102,17 +101,13 @@ ppSourceStats short (HsModule _ exports imports decls _ src_loc) count_monobinds (PatMonoBind p r _) = (0,1) count_monobinds (FunMonoBind f _ m _) = (0,1) - count_mb_monobinds (Just mbs) = count_monobinds mbs - count_mb_monobinds Nothing = (0,0) + count_sigs sigs = foldr add4 (0,0,0,0) (map sig_info sigs) - count_sigs sigs = foldr add5 (0,0,0,0,0) (map sig_info sigs) - - sig_info (FixSig _) = (1,0,0,0,0) - sig_info (Sig _ _ _) = (0,1,0,0,0) - sig_info (ClassOpSig _ _ _ _) = (0,0,1,0,0) - sig_info (SpecSig _ _ _) = (0,0,0,1,0) - sig_info (InlineSig _ _ _ _) = (0,0,0,0,1) - sig_info _ = (0,0,0,0,0) + sig_info (FixSig _) = (1,0,0,0) + sig_info (Sig _ _ _) = (0,1,0,0) + sig_info (SpecSig _ _ _) = (0,0,1,0) + sig_info (InlineSig _ _ _ _) = (0,0,0,1) + sig_info _ = (0,0,0,0) import_info (ImportDecl _ _ qual as spec _) = add6 (1, qual_info qual, as_info as, 0,0,0) (spec_info spec) @@ -124,35 +119,31 @@ ppSourceStats short (HsModule _ exports imports decls _ src_loc) spec_info (Just (False, _)) = (0,0,0,0,1,0) spec_info (Just (True, _)) = (0,0,0,0,0,1) - data_info (TyData {tcdCons = DataCons cs, tcdDerivs = derivs}) + data_info (TyData {tcdCons = cs, tcdDerivs = derivs}) = (length cs, case derivs of {Nothing -> 0; Just ds -> length ds}) data_info other = (0,0) class_info decl@(ClassDecl {}) = case count_sigs (tcdSigs decl) of - (_,_,classops,_,_) -> - (classops, addpr (count_mb_monobinds (tcdMeths decl))) + (_,classops,_,_) -> + (classops, addpr (count_monobinds (tcdMeths decl))) class_info other = (0,0) - inst_info (InstDecl _ inst_meths inst_sigs _ _) + inst_info (InstDecl _ inst_meths inst_sigs _) = case count_sigs inst_sigs of - (_,_,_,ss,is) -> + (_,_,ss,is) -> (addpr (count_monobinds inst_meths), ss, is) addpr :: (Int,Int) -> Int - add1 :: Int -> Int -> Int add2 :: (Int,Int) -> (Int,Int) -> (Int, Int) add3 :: (Int,Int,Int) -> (Int,Int,Int) -> (Int, Int, Int) add4 :: (Int,Int,Int,Int) -> (Int,Int,Int,Int) -> (Int, Int, Int, Int) - add5 :: (Int,Int,Int,Int,Int) -> (Int,Int,Int,Int,Int) -> (Int, Int, Int, Int, Int) add6 :: (Int,Int,Int,Int,Int,Int) -> (Int,Int,Int,Int,Int,Int) -> (Int, Int, Int, Int, Int, Int) addpr (x,y) = x+y - add1 x1 y1 = x1+y1 add2 (x1,x2) (y1,y2) = (x1+y1,x2+y2) add3 (x1,x2,x3) (y1,y2,y3) = (x1+y1,x2+y2,x3+y3) add4 (x1,x2,x3,x4) (y1,y2,y3,y4) = (x1+y1,x2+y2,x3+y3,x4+y4) - add5 (x1,x2,x3,x4,x5) (y1,y2,y3,y4,y5) = (x1+y1,x2+y2,x3+y3,x4+y4,x5+y5) add6 (x1,x2,x3,x4,x5,x6) (y1,y2,y3,y4,y5,y6) = (x1+y1,x2+y2,x3+y3,x4+y4,x5+y5,x6+y6) \end{code} diff --git a/ghc/compiler/main/HscTypes.lhs b/ghc/compiler/main/HscTypes.lhs index 88fd6b9562..7cb86bfb42 100644 --- a/ghc/compiler/main/HscTypes.lhs +++ b/ghc/compiler/main/HscTypes.lhs @@ -1,64 +1,59 @@ -% + % (c) The University of Glasgow, 2000 % \section[HscTypes]{Types for the per-module compiler} \begin{code} module HscTypes ( - HscEnv(..), + HscEnv(..), hscEPS, GhciMode(..), - ModDetails(..), ModIface(..), + ModDetails(..), ModGuts(..), ModImports(..), ForeignStubs(..), - ParsedIface(..), IfaceDeprecs, HomePackageTable, HomeModInfo(..), emptyHomePackageTable, - ExternalPackageState(..), emptyExternalPackageState, + ExternalPackageState(..), PackageTypeEnv, PackageIfaceTable, emptyPackageIfaceTable, lookupIface, lookupIfaceByModName, moduleNameToModule, emptyModIface, - InteractiveContext(..), emptyInteractiveContext, icPrintUnqual, + InteractiveContext(..), emptyInteractiveContext, + icPrintUnqual, unQualInScope, + + ModIface(..), mkIfaceDepCache, mkIfaceVerCache, mkIfaceFixCache, + emptyIfaceDepCache, - IfaceDecls, mkIfaceDecls, dcl_tycl, dcl_rules, dcl_insts, + Deprecs(..), IfaceDeprecs, - VersionInfo(..), initialVersionInfo, lookupVersion, - FixityEnv, lookupFixity, collectFixities, emptyFixityEnv, + FixityEnv, FixItem(..), lookupFixity, emptyFixityEnv, - TyThing(..), implicitTyThings, + implicitTyThings, isImplicitTyThing, + TyThing(..), tyThingClass, tyThingTyCon, tyThingDataCon, tyThingId, TypeEnv, lookupType, mkTypeEnv, emptyTypeEnv, - extendTypeEnvList, extendTypeEnvWithIds, + extendTypeEnvList, extendTypeEnvWithIds, lookupTypeEnv, typeEnvElts, typeEnvClasses, typeEnvTyCons, typeEnvIds, - WhetherHasOrphans, IsBootInterface, DeclsMap, Usage(..), + WhetherHasOrphans, IsBootInterface, Usage(..), Dependencies(..), noDependencies, - IfaceInsts, IfaceRules, GatedDecl, GatedDecls, GateFn, + Pool(..), emptyPool, DeclPool, InstPool, + Gated, + RulePool, addRuleToPool, NameCache(..), OrigNameCache, OrigIParamCache, Avails, availsToNameSet, availName, availNames, GenAvailInfo(..), AvailInfo, RdrAvailInfo, - ExportItem, RdrExportItem, + IfaceExport, - PersistentCompilerState(..), + Deprecations, DeprecTxt, lookupDeprec, plusDeprecs, - Deprecations(..), lookupDeprec, plusDeprecs, - - InstEnv, ClsInstEnv, DFunId, + InstEnv, DFunId, PackageInstEnv, PackageRuleBase, - GlobalRdrEnv, GlobalRdrElt(..), emptyGlobalRdrEnv, pprGlobalRdrEnv, - LocalRdrEnv, extendLocalRdrEnv, isLocalGRE, unQualInScope, - -- Linker stuff Linkable(..), isObjectLinkable, Unlinked(..), CompiledByteCode, - isObject, nameOfObject, isInterpretable, byteCodeOfObject, - - -- Provenance - Provenance(..), ImportReason(..), - pprNameProvenance, hasBetterProv - + isObject, nameOfObject, isInterpretable, byteCodeOfObject ) where #include "HsVersions.h" @@ -67,48 +62,43 @@ module HscTypes ( import ByteCodeAsm ( CompiledByteCode ) #endif -import RdrName ( RdrName, mkRdrUnqual, - RdrNameEnv, addListToRdrEnv, foldRdrEnv, isUnqual, - rdrEnvToList, emptyRdrEnv ) -import Name ( Name, NamedThing, getName, nameOccName, nameModule, nameSrcLoc ) +import RdrName ( GlobalRdrEnv, emptyGlobalRdrEnv, + LocalRdrEnv, emptyLocalRdrEnv, + GlobalRdrElt(..), unQualOK ) +import Name ( Name, NamedThing, getName, nameOccName, nameModule ) import NameEnv import NameSet -import OccName ( OccName ) +import OccName ( OccName, OccEnv, lookupOccEnv, mkOccEnv, emptyOccEnv, + extendOccEnv, foldOccEnv ) import Module -import InstEnv ( InstEnv, ClsInstEnv, DFunId ) +import InstEnv ( InstEnv, DFunId ) import Rules ( RuleBase ) import CoreSyn ( CoreBind ) -import Id ( Id, idName ) +import Id ( Id, isImplicitId ) +import Type ( TyThing(..) ) + 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 TyCon ( TyCon, isClassTyCon, tyConSelIds, tyConDataCons ) +import DataCon ( dataConImplicitIds ) +import Packages ( PackageName ) import CmdLineOpts ( DynFlags ) -import BasicTypes ( Version, initialVersion, IPName, - Fixity, FixitySig(..), defaultFixity ) +import BasicTypes ( Version, initialVersion, IPName, + Fixity, defaultFixity, DeprecTxt ) -import HsSyn ( DeprecTxt, TyClDecl, InstDecl, RuleDecl, - tyClDeclName, ifaceRuleDeclName, tyClDeclNames, - instDeclDFun ) -import RnHsSyn ( RenamedTyClDecl, RenamedRuleDecl, RenamedInstDecl ) +import IfaceSyn ( IfaceInst, IfaceRule, IfaceDecl(ifName) ) +import FiniteMap ( FiniteMap ) import CoreSyn ( IdCoreRule ) import PrelNames ( isBuiltInSyntaxName ) -import InstEnv ( emptyInstEnv ) -import Rules ( emptyRuleBase ) - -import FiniteMap -import Bag ( Bag, emptyBag ) import Maybes ( orElse ) import Outputable -import SrcLoc ( SrcLoc, isGoodSrcLoc ) -import Util ( thenCmp, sortLt ) +import SrcLoc ( SrcLoc ) import UniqSupply ( UniqSupply ) import Maybe ( fromJust ) import FastString ( FastString ) +import DATA_IOREF ( IORef, readIORef ) import Time ( ClockTime ) \end{code} @@ -122,9 +112,28 @@ import Time ( ClockTime ) The HscEnv gives the environment in which to compile a chunk of code. \begin{code} -data HscEnv = HscEnv { hsc_mode :: GhciMode, - hsc_dflags :: DynFlags, - hsc_HPT :: HomePackageTable } +data HscEnv + = HscEnv { hsc_mode :: GhciMode, + hsc_dflags :: DynFlags, + + hsc_HPT :: HomePackageTable, + -- The home package table describes already-compiled + -- home-packge modules, *excluding* the module we + -- are compiling right now. + -- (In one-shot mode the current module is the only + -- home-package module, so hsc_HPT is empty. All other + -- modules count as "external-package" modules.) + -- hsc_HPT is not mutable because we only demand-load + -- external packages; the home package is eagerly + -- loaded by the compilation manager. + + -- The next two are side-effected by compiling + -- to reflect sucking in interface files + hsc_EPS :: IORef ExternalPackageState, + hsc_NC :: IORef NameCache } + +hscEPS :: HscEnv -> IO ExternalPackageState +hscEPS hsc_env = readIORef (hsc_EPS hsc_env) \end{code} The GhciMode is self-explanatory: @@ -141,9 +150,12 @@ type PackageIfaceTable = ModuleEnv ModIface -- Domain = modules in the imported emptyHomePackageTable = emptyModuleEnv emptyPackageIfaceTable = emptyModuleEnv -data HomeModInfo = HomeModInfo { hm_iface :: ModIface, - hm_details :: ModDetails, - hm_linkable :: Linkable } +data HomeModInfo + = HomeModInfo { hm_iface :: ModIface, + hm_globals :: Maybe GlobalRdrEnv, -- Its top level environment + -- Nothing <-> compiled module + hm_details :: ModDetails, + hm_linkable :: Linkable } \end{code} Simple lookups in the symbol table. @@ -192,38 +204,58 @@ the declarations into a single indexed map in the @PersistentRenamerState@. \begin{code} data ModIface = ModIface { - mi_module :: !Module, mi_package :: !PackageName, -- Which package the module comes from - mi_version :: !VersionInfo, -- Version info for everything in this module + mi_module :: !Module, + mi_mod_vers :: !Version, -- Module version: changes when anything changes + mi_orphan :: !WhetherHasOrphans, -- Whether this module has orphans mi_boot :: !IsBootInterface, -- Read from an hi-boot file? mi_deps :: Dependencies, - -- This is consulted for directly-imported modules, but - -- not for anything else + -- This is consulted for directly-imported modules, + -- but not for anything else (hence lazy) - mi_usages :: [Usage Name], -- Usages; kept sorted so that it's easy to decide -- whether to write a new iface file (changing usages -- doesn't affect the version of this module) + mi_usages :: [Usage], -- NOT STRICT! we read this field lazily from the interface file -- It is *only* consulted by the recompilation checker - mi_exports :: ![ExportItem], - -- What it exports Kept sorted by (mod,occ), to make - -- version comparisons easier + -- Exports + -- Kept sorted by (mod,occ), to make version comparisons easier + mi_exports :: ![IfaceExport], + mi_exp_vers :: !Version, -- Version number of export list - mi_globals :: !(Maybe GlobalRdrEnv), - -- Its top level environment or Nothing if we read this - -- interface from an interface file. (We need the source - -- file to figure out the top-level environment.) + -- Fixities + mi_fixities :: [(OccName,Fixity)], + -- NOT STRICT! we read this field lazily from the interface file - mi_fixities :: !FixityEnv, -- Fixities - mi_deprecs :: Deprecations, -- Deprecations - -- NOT STRICT! we read this field lazilly from the interface file + -- Deprecations + mi_deprecs :: Deprecs [(OccName,DeprecTxt)], + -- NOT STRICT! we read this field lazily from the interface file - mi_decls :: IfaceDecls -- The RnDecls form of ModDetails - -- NOT STRICT! we fill this field with _|_ sometimes + -- Type, class and variable declarations + -- The version of an Id changes if its fixity or deprecations change + -- (as well as its type of course) + -- Ditto data constructors, class operations, except that + -- the version of the parent class/tycon changes + mi_decls :: [(Version,IfaceDecl)], -- Sorted + + -- Instance declarations and rules + mi_insts :: [IfaceInst], -- Sorted + mi_rules :: [IfaceRule], -- Sorted + mi_rule_vers :: !Version, -- Version number for rules and instances combined + + -- Cached environments for easy lookup + -- These are computed (lazily) from other fields + -- and are not put into the interface file + mi_dep_fn :: Name -> Maybe DeprecTxt, -- Cached lookup for mi_deprecs + mi_fix_fn :: OccName -> Fixity, -- Cached lookup for mi_fixities + mi_ver_fn :: OccName -> Maybe Version -- Cached lookup for mi_decls + -- The Nothing in mi_ver_fn means that the thing + -- isn't in decls. It's useful to know that when + -- seeing if we are up to date wrt the old interface } -- Should be able to construct ModDetails from mi_decls in ModIface @@ -247,7 +279,7 @@ data ModGuts mg_deps :: !Dependencies, -- What is below it, directly or otherwise mg_dir_imps :: ![Module], -- Directly-imported modules; used to -- generate initialisation code - mg_usages :: ![Usage Name], -- Version info for what it needed + mg_usages :: ![Usage], -- Version info for what it needed mg_rdr_env :: !GlobalRdrEnv, -- Top-level lexical environment mg_fix_env :: !FixityEnv, -- Fixity env, for things declared in this module @@ -305,76 +337,35 @@ data ForeignStubs = NoStubs [Id] -- Foreign-exported binders -- we have to generate code to register these - -data IfaceDecls = IfaceDecls { dcl_tycl :: [RenamedTyClDecl], -- Sorted - dcl_rules :: [RenamedRuleDecl], -- Sorted - dcl_insts :: [RenamedInstDecl] } -- Unsorted - -mkIfaceDecls :: [RenamedTyClDecl] -> [RenamedRuleDecl] -> [RenamedInstDecl] -> IfaceDecls --- Sort to put them in canonical order for version comparison -mkIfaceDecls tycls rules insts - = IfaceDecls { dcl_tycl = sortLt lt_tycl tycls, - dcl_rules = sortLt lt_rule rules, - dcl_insts = sortLt lt_inst insts } - where - d1 `lt_tycl` d2 = tyClDeclName d1 < tyClDeclName d2 - r1 `lt_rule` r2 = ifaceRuleDeclName r1 < ifaceRuleDeclName r2 - i1 `lt_inst` i2 = instDeclDFun i1 < instDeclDFun i2 \end{code} \begin{code} -emptyModIface :: Module -> ModIface -emptyModIface mod - = ModIface { mi_module = mod, - mi_package = basePackage, -- XXX fully bogus - mi_version = initialVersionInfo, - mi_usages = [], - mi_deps = noDependencies, +emptyModIface :: PackageName -> ModuleName -> ModIface +emptyModIface pkg mod + = ModIface { mi_package = pkg, + mi_module = mkModule pkg mod, + mi_mod_vers = initialVersion, mi_orphan = False, mi_boot = False, + mi_deps = noDependencies, + mi_usages = [], mi_exports = [], - mi_fixities = emptyNameEnv, - mi_globals = Nothing, + mi_exp_vers = initialVersion, + mi_fixities = [], mi_deprecs = NoDeprecs, - mi_decls = panic "emptyModIface: decls" + mi_insts = [], + mi_rules = [], + mi_decls = [], + mi_rule_vers = initialVersion, + mi_dep_fn = emptyIfaceDepCache, + mi_fix_fn = emptyIfaceFixCache, + mi_ver_fn = emptyIfaceVerCache } \end{code} %************************************************************************ %* * - Parsed interface files -%* * -%************************************************************************ - -A ParsedIface is exactly as read from an interface file. - -\begin{code} -type IfaceDeprecs = Maybe (Either DeprecTxt [(RdrName,DeprecTxt)]) - -- Nothing => NoDeprecs - -- Just (Left t) => DeprecAll - -- Just (Right p) => DeprecSome - -data ParsedIface - = ParsedIface { - pi_mod :: ModuleName, - pi_pkg :: PackageName, - pi_vers :: Version, -- Module version number - pi_orphan :: WhetherHasOrphans, -- Whether this module has orphans - pi_deps :: Dependencies, -- What it depends on - pi_usages :: [Usage OccName], -- Usages - pi_exports :: (Version, [RdrExportItem]), -- Exports - pi_decls :: [(Version, TyClDecl RdrName)], -- Local definitions - pi_fixity :: [FixitySig RdrName], -- Local fixity declarations, - pi_insts :: [InstDecl RdrName], -- Local instance declarations - pi_rules :: (Version, [RuleDecl RdrName]), -- Rules, with their version - pi_deprecs :: IfaceDeprecs -- Deprecations - } -\end{code} - - -%************************************************************************ -%* * \subsection{The interactive context} %* * %************************************************************************ @@ -382,10 +373,10 @@ data ParsedIface \begin{code} data InteractiveContext = InteractiveContext { - ic_toplev_scope :: [Module], -- Include the "top-level" scope of + ic_toplev_scope :: [String], -- Include the "top-level" scope of -- these modules - ic_exports :: [Module], -- Include just the exports of these + ic_exports :: [String], -- Include just the exports of these -- modules ic_rn_gbl_env :: GlobalRdrEnv, -- The cached GlobalRdrEnv, built from @@ -400,86 +391,111 @@ data InteractiveContext emptyInteractiveContext = InteractiveContext { ic_toplev_scope = [], ic_exports = [], - ic_rn_gbl_env = emptyRdrEnv, - ic_rn_local_env = emptyRdrEnv, + ic_rn_gbl_env = emptyGlobalRdrEnv, + ic_rn_local_env = emptyLocalRdrEnv, ic_type_env = emptyTypeEnv } icPrintUnqual :: InteractiveContext -> PrintUnqualified icPrintUnqual ictxt = unQualInScope (ic_rn_gbl_env ictxt) \end{code} +@unQualInScope@ returns a function that takes a @Name@ and tells whether +its unqualified name is in scope. This is put as a boolean flag in +the @Name@'s provenance to guide whether or not to print the name qualified +in error messages. + +\begin{code} +unQualInScope :: GlobalRdrEnv -> Name -> Bool +-- True if 'f' is in scope, and has only one binding, +-- and the thing it is bound to is the name we are looking for +-- (i.e. false if A.f and B.f are both in scope as unqualified 'f') +-- +-- Also checks for built-in syntax, which is always 'in scope' +-- +-- This fn is only efficient if the shared +-- partial application is used a lot. +unQualInScope env + = \n -> n `elemNameSet` unqual_names || isBuiltInSyntaxName n + where + unqual_names :: NameSet + unqual_names = foldOccEnv add emptyNameSet env + add [gre] unquals | unQualOK gre = addOneToNameSet unquals (gre_name gre) + add _ unquals = unquals +\end{code} + %************************************************************************ %* * -\subsection{Type environment stuff} + TyThing %* * %************************************************************************ \begin{code} +isImplicitTyThing :: TyThing -> Bool +isImplicitTyThing (ADataCon dc) = True +isImplicitTyThing (AnId id) = isImplicitId id +isImplicitTyThing (ATyCon tc) = isClassTyCon tc +isImplicitTyThing other = False + +implicitTyThings :: TyThing -> [TyThing] +implicitTyThings (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? +implicitTyThings (ATyCon tc) = map AnId (tyConSelIds tc) ++ + concatMap (extras_plus . ADataCon) (tyConDataCons tc) + + -- For classes, add the class TyCon too (and its extras) + -- and the class selector Ids +implicitTyThings (AClass cl) = map AnId (classSelIds cl) ++ + extras_plus (ATyCon (classTyCon cl)) + + + -- For data cons add the worker and wrapper (if any) +implicitTyThings (ADataCon dc) = map AnId (dataConImplicitIds dc) + +extras_plus thing = thing : implicitTyThings thing + +extendTypeEnvWithIds :: TypeEnv -> [Id] -> TypeEnv +extendTypeEnvWithIds env ids + = extendNameEnvList env [(getName id, AnId id) | id <- ids] +\end{code} + +%************************************************************************ +%* * + TypeEnv +%* * +%************************************************************************ + +\begin{code} +type TypeEnv = NameEnv TyThing + +emptyTypeEnv :: TypeEnv typeEnvElts :: TypeEnv -> [TyThing] typeEnvClasses :: TypeEnv -> [Class] typeEnvTyCons :: TypeEnv -> [TyCon] typeEnvIds :: TypeEnv -> [Id] +lookupTypeEnv :: TypeEnv -> Name -> Maybe TyThing +emptyTypeEnv = emptyNameEnv 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] -\end{code} - - -\begin{code} -type TypeEnv = NameEnv TyThing - -emptyTypeEnv = emptyNameEnv mkTypeEnv :: [TyThing] -> TypeEnv mkTypeEnv things = extendTypeEnvList emptyTypeEnv things +lookupTypeEnv = lookupNameEnv + extendTypeEnvList :: TypeEnv -> [TyThing] -> TypeEnv -- Extend the type environment extendTypeEnvList env 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 = (if (null dcs) then [] else [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 - = extendNameEnvList env [(getName id, AnId id) | id <- ids] \end{code} \begin{code} @@ -490,6 +506,21 @@ lookupType hpt pte name Nothing -> lookupNameEnv pte name \end{code} + +\begin{code} +tyThingTyCon (ATyCon tc) = tc +tyThingTyCon other = pprPanic "tyThingTyCon" (ppr other) + +tyThingClass (AClass cls) = cls +tyThingClass other = pprPanic "tyThingClass" (ppr other) + +tyThingDataCon (ADataCon dc) = dc +tyThingDataCon other = pprPanic "tyThingDataCon" (ppr other) + +tyThingId (AnId id) = id +tyThingId other = pprPanic "tyThingId" (ppr other) +\end{code} + %************************************************************************ %* * \subsection{Auxiliary types} @@ -500,35 +531,33 @@ These types are defined here because they are mentioned in ModDetails, but they are mostly elaborated elsewhere \begin{code} -data VersionInfo - = VersionInfo { - vers_module :: Version, -- Changes when anything changes - vers_exports :: Version, -- Changes when export list changes - vers_rules :: Version, -- Changes when any rule changes - vers_decls :: NameEnv Version - -- Versions for "big" names only (not data constructors, class ops) - -- The version of an Id changes if its fixity changes - -- Ditto data constructors, class operations, except that the version of - -- the parent class/tycon changes - -- - -- If a name isn't in the map, it means 'initialVersion' - } +mkIfaceVerCache :: [(Version,IfaceDecl)] -> OccName -> Maybe Version +mkIfaceVerCache pairs + = \occ -> lookupOccEnv env occ + where + env = foldl add emptyOccEnv pairs + add env (v,d) = extendOccEnv env (ifName d) v + +emptyIfaceVerCache :: OccName -> Maybe Version +emptyIfaceVerCache occ = Nothing + +------------------ Deprecations ------------------------- +data Deprecs a + = NoDeprecs + | DeprecAll DeprecTxt -- Whole module deprecated + | DeprecSome a -- Some specific things deprecated + deriving( Eq ) -initialVersionInfo :: VersionInfo -initialVersionInfo = VersionInfo { vers_module = initialVersion, - vers_exports = initialVersion, - vers_rules = initialVersion, - vers_decls = emptyNameEnv - } +type IfaceDeprecs = Deprecs [(OccName,DeprecTxt)] +type Deprecations = Deprecs (NameEnv (OccName,DeprecTxt)) -lookupVersion :: NameEnv Version -> Name -> Version -lookupVersion env name = lookupNameEnv env name `orElse` initialVersion +mkIfaceDepCache:: IfaceDeprecs -> Name -> Maybe DeprecTxt +mkIfaceDepCache NoDeprecs = \n -> Nothing +mkIfaceDepCache (DeprecAll t) = \n -> Just t +mkIfaceDepCache (DeprecSome pairs) = lookupOccEnv (mkOccEnv pairs) . nameOccName -data Deprecations = NoDeprecs - | DeprecAll DeprecTxt -- Whole module deprecated - | DeprecSome (NameEnv (Name,DeprecTxt)) -- Some things deprecated - -- Just "big" names - -- We keep the Name in the range, so we can print them out +emptyIfaceDepCache :: Name -> Maybe DeprecTxt +emptyIfaceDepCache n = Nothing lookupDeprec :: Deprecations -> Name -> Maybe DeprecTxt lookupDeprec NoDeprecs name = Nothing @@ -543,13 +572,6 @@ plusDeprecs NoDeprecs d = d plusDeprecs d (DeprecAll t) = DeprecAll t plusDeprecs (DeprecAll t) d = DeprecAll t plusDeprecs (DeprecSome v1) (DeprecSome v2) = DeprecSome (v1 `plusNameEnv` v2) - -instance Eq Deprecations where - -- Used when checking whether we need write a new interface - NoDeprecs == NoDeprecs = True - (DeprecAll t1) == (DeprecAll t2) = t1 == t2 - (DeprecSome e1) == (DeprecSome e2) = nameEnvElts e1 == nameEnvElts e2 - d1 == d2 = False \end{code} @@ -567,8 +589,7 @@ data GenAvailInfo name = Avail name -- An ordinary identifier deriving( Eq ) -- Equality used when deciding if the interface has changed -type RdrExportItem = (ModuleName, [RdrAvailInfo]) -type ExportItem = (ModuleName, [AvailInfo]) +type IfaceExport = (ModuleName, [GenAvailInfo OccName]) availsToNameSet :: [AvailInfo] -> NameSet availsToNameSet avails = foldl add emptyNameSet avails @@ -595,26 +616,31 @@ pprAvail (Avail n) = ppr n \end{code} \begin{code} -type FixityEnv = NameEnv (FixitySig Name) - -- We keep the whole fixity sig so that we - -- can report line-number info when there is a duplicate - -- fixity declaration +mkIfaceFixCache :: [(OccName, Fixity)] -> OccName -> Fixity +mkIfaceFixCache pairs + = \n -> lookupOccEnv env n `orElse` defaultFixity + where + env = mkOccEnv pairs + +emptyIfaceFixCache :: OccName -> Fixity +emptyIfaceFixCache n = defaultFixity + +-- This fixity environment is for source code only +type FixityEnv = NameEnv FixItem + +-- We keep the OccName in the range so that we can generate an interface from it +data FixItem = FixItem OccName Fixity SrcLoc + +instance Outputable FixItem where + ppr (FixItem occ fix loc) = ppr fix <+> ppr occ <+> parens (ppr loc) emptyFixityEnv :: FixityEnv emptyFixityEnv = emptyNameEnv lookupFixity :: FixityEnv -> Name -> Fixity lookupFixity env n = case lookupNameEnv env n of - Just (FixitySig _ fix _) -> fix - Nothing -> defaultFixity - -collectFixities :: FixityEnv -> [TyClDecl Name] -> [FixitySig Name] --- Collect fixities for the specified declarations -collectFixities env decls - = [ fix - | d <- decls, (n,_) <- tyClDeclNames d, - Just fix <- [lookupNameEnv env n] - ] + Just (FixItem _ fix _) -> fix + Nothing -> defaultFixity \end{code} @@ -646,12 +672,13 @@ data Dependencies noDependencies :: Dependencies noDependencies = Deps [] [] [] -data Usage name - = Usage { usg_name :: ModuleName, -- Name of the module - usg_mod :: Version, -- Module version - usg_exports :: Maybe Version, -- Export-list version, if we depend on it - usg_entities :: [(name,Version)], -- Sorted by occurrence name - usg_rules :: Version -- Rules version +data Usage + = Usage { usg_name :: ModuleName, -- Name of the module + usg_mod :: Version, -- Module version + usg_entities :: [(OccName,Version)], -- Sorted by occurrence name + usg_exports :: Maybe Version, -- Export-list version, if we depend on it + usg_rules :: Version -- Orphan-rules version (for non-orphan + -- modules this will always be initialVersion) } deriving( Eq ) -- This type doesn't let you say "I imported f but none of the rules in -- the module". If you use anything in the module you get its rule version @@ -668,23 +695,10 @@ data Usage name %************************************************************************ %* * -\subsection{The persistent compiler state} + The External Package State %* * %************************************************************************ -The @PersistentCompilerState@ persists across successive calls to the -compiler. - -\begin{code} -data PersistentCompilerState - = PCS { - pcs_nc :: !NameCache, - pcs_EPS :: ExternalPackageState - -- non-strict because we fill it with error in HscMain - } -\end{code} - - \begin{code} type PackageTypeEnv = TypeEnv type PackageRuleBase = RuleBase @@ -714,35 +728,26 @@ data ExternalPackageState -- Holding pens for stuff that has been read in from file, -- but not yet slurped into the renamer - eps_decls :: !DeclsMap, + eps_decls :: !DeclPool, -- A single, global map of Names to unslurped decls - eps_insts :: !IfaceInsts, - -- The as-yet un-slurped instance decls; this bag is depleted when we - -- slurp an instance decl so that we don't slurp the same one twice. - -- Each is 'gated' by the names that must be available before - -- this instance decl is needed. - eps_rules :: !IfaceRules, - -- Similar to instance decls, only for rules - - eps_inst_gates :: !NameSet -- Gates for instance decls - -- The instance gates must accumulate across - -- all invocations of the renamer; - -- see "the gating story" in RnIfaces.lhs - -- These names should all be from other packages; - -- for the home package we have all the instance - -- declarations anyhow + -- Decls move from here to eps_PTE + + eps_insts :: !InstPool, + -- The as-yet un-slurped instance decls + -- Decls move from here to eps_inst_env + -- Each instance is 'gated' by the names that must be + -- available before this instance decl is needed. + + eps_rules :: !RulePool + -- Rules move from here to eps_rule_base when + -- all their LHS free vars are in the eps_PTE + -- To maintain this invariant, we need to check the pool + -- a) when adding to the rule pool by loading an interface + -- (some of the new rules may alrady have all their + -- gates in the eps_PTE) + -- b) when extending the eps_PTE when we load a decl + -- from the eps_decls pool } - -emptyExternalPackageState = EPS { - eps_decls = (emptyNameEnv, 0), - eps_insts = (emptyBag, 0), - eps_inst_gates = emptyNameSet, - eps_rules = (emptyBag, 0), - eps_PIT = emptyPackageIfaceTable, - eps_PTE = emptyTypeEnv, - eps_inst_env = emptyInstEnv, - eps_rule_base = emptyRuleBase - } \end{code} The NameCache makes sure that there is just one Unique assigned for @@ -767,31 +772,43 @@ data NameCache -- Ensures that one implicit parameter name gets one unique } -type OrigNameCache = ModuleEnv (Module, OccNameCache) - -- Maps a module *name* to a Module, - -- plus the OccNameEnv fot that module -type OccNameCache = FiniteMap OccName Name - -- Maps the OccName to a Name - -- A FiniteMap because OccNames have a Namespace/Faststring pair - -type OrigIParamCache = FiniteMap (IPName RdrName) (IPName Name) +type OrigNameCache = ModuleEnv (OccEnv Name) +type OrigIParamCache = FiniteMap (IPName OccName) (IPName Name) \end{code} -A DeclsMap contains a binding for each Name in the declaration -including the constructors of a type decl etc. The Bool is True just -for the 'main' Name. - \begin{code} -type DeclsMap = (NameEnv (AvailInfo, Bool, (Module, TyClDecl RdrName)), Int) - -- The Int says how many have been sucked in - -type IfaceInsts = GatedDecls (InstDecl RdrName) -type IfaceRules = GatedDecls (RuleDecl RdrName) - -type GatedDecls d = (Bag (GatedDecl d), Int) -- The Int says how many have been sucked in -type GatedDecl d = (GateFn, (Module, d)) -type GateFn = (Name -> Bool) -> Bool -- Returns True <=> gate is open - -- The (Name -> Bool) fn returns True for visible Names +data Pool p = Pool (NameEnv p) -- The pool itself, indexed by some primary key + Int -- Number of decls slurped into the map + Int -- Number of decls slurped out of the map + +emptyPool = Pool emptyNameEnv 0 0 + +instance Outputable p => Outputable (Pool p) where + ppr (Pool p n_in n_out) -- Debug printing only + = vcat [ptext SLIT("Pool") <+> int n_in <+> int n_out, + nest 2 (ppr p)] + +type DeclPool = Pool IfaceDecl + +------------------------- +type Gated d = ([Name], (ModuleName, d)) -- The [Name] 'gate' the declaration + -- ModuleName records which iface file this + -- decl came from + +type RulePool = Pool [Gated IfaceRule] + +addRuleToPool :: NameEnv [Gated IfaceRule] + -> (ModuleName, IfaceRule) + -> [Name] -- Free vars of rule; always non-empty + -> NameEnv [Gated IfaceRule] +addRuleToPool rules rule (fv:fvs) = extendNameEnv_C combine rules fv [(fvs,rule)] + where + combine old _ = (fvs,rule) : old + +------------------------- +type InstPool = Pool [Gated IfaceInst] + -- The key of the Pool is the Class + -- The Names are the TyCons in the instance head -- For example, suppose this is in an interface file -- instance C T where ... -- We want to slurp this decl if both C and T are "visible" in @@ -861,156 +878,4 @@ byteCodeOfObject (BCOs bc) = bc \end{code} -%************************************************************************ -%* * -\subsection{Provenance and export info} -%* * -%************************************************************************ - -A LocalRdrEnv is used for local bindings (let, where, lambda, case) -Also used in - -\begin{code} -type LocalRdrEnv = RdrNameEnv Name - -extendLocalRdrEnv :: LocalRdrEnv -> [Name] -> LocalRdrEnv -extendLocalRdrEnv env names - = addListToRdrEnv env [(mkRdrUnqual (nameOccName n), n) | n <- names] -\end{code} - -The GlobalRdrEnv gives maps RdrNames to Names. There is a separate -one for each module, corresponding to that module's top-level scope. - -\begin{code} -type GlobalRdrEnv = RdrNameEnv [GlobalRdrElt] - -- The list is because there may be name clashes - -- These only get reported on lookup, not on construction - -emptyGlobalRdrEnv = emptyRdrEnv - -data GlobalRdrElt - = GRE { gre_name :: Name, - gre_parent :: Maybe Name, -- Name of the "parent" structure, for - -- * the tycon of a data con - -- * the class of a class op - -- For others it's Nothing - -- Invariant: gre_name g /= gre_parent g - -- when the latter is a Just - - gre_prov :: Provenance, -- Why it's in scope - gre_deprec :: Maybe DeprecTxt -- Whether this name is deprecated - } - -instance Outputable GlobalRdrElt where - ppr gre = ppr (gre_name gre) <+> - parens (pp_parent (gre_parent gre) <+> pprNameProvenance gre) - where - pp_parent (Just p) = text "parent:" <+> ppr p <> comma - pp_parent Nothing = empty - -pprGlobalRdrEnv env - = vcat (map pp (rdrEnvToList env)) - where - pp (rn, gres) = ppr rn <> colon <+> - vcat [ ppr (gre_name gre) <+> pprNameProvenance gre - | gre <- gres] - -isLocalGRE :: GlobalRdrElt -> Bool -isLocalGRE (GRE {gre_prov = LocalDef}) = True -isLocalGRE other = False -\end{code} - -@unQualInScope@ returns a function that takes a @Name@ and tells whether -its unqualified name is in scope. This is put as a boolean flag in -the @Name@'s provenance to guide whether or not to print the name qualified -in error messages. -\begin{code} -unQualInScope :: GlobalRdrEnv -> Name -> Bool --- True if 'f' is in scope, and has only one binding, --- and the thing it is bound to is the name we are looking for --- (i.e. false if A.f and B.f are both in scope as unqualified 'f') --- --- Also checks for built-in syntax, which is always 'in scope' --- --- This fn is only efficient if the shared --- partial application is used a lot. -unQualInScope env - = \n -> n `elemNameSet` unqual_names || isBuiltInSyntaxName n - where - unqual_names :: NameSet - unqual_names = foldRdrEnv add emptyNameSet env - add rdr_name [gre] unquals | isUnqual rdr_name = addOneToNameSet unquals (gre_name gre) - add _ _ unquals = unquals -\end{code} - -The "provenance" of something says how it came to be in scope. - -\begin{code} -data Provenance - = LocalDef -- Defined locally - - | NonLocalDef -- Defined non-locally - ImportReason - --- Just used for grouping error messages (in RnEnv.warnUnusedBinds) -instance Eq Provenance where - p1 == p2 = case p1 `compare` p2 of EQ -> True; _ -> False - -instance Eq ImportReason where - p1 == p2 = case p1 `compare` p2 of EQ -> True; _ -> False - -instance Ord Provenance where - compare LocalDef LocalDef = EQ - compare LocalDef (NonLocalDef _) = LT - compare (NonLocalDef _) LocalDef = GT - - compare (NonLocalDef reason1) (NonLocalDef reason2) - = compare reason1 reason2 - -instance Ord ImportReason where - compare ImplicitImport ImplicitImport = EQ - compare ImplicitImport (UserImport _ _ _) = LT - compare (UserImport _ _ _) ImplicitImport = GT - compare (UserImport m1 loc1 _) (UserImport m2 loc2 _) - = (m1 `compare` m2) `thenCmp` (loc1 `compare` loc2) - - -data ImportReason - = UserImport Module SrcLoc Bool -- Imported from module M on line L - -- Note the M may well not be the defining module - -- for this thing! - -- The Bool is true iff the thing was named *explicitly* in the import spec, - -- rather than being imported as part of a group; e.g. - -- import B - -- import C( T(..) ) - -- Here, everything imported by B, and the constructors of T - -- are not named explicitly; only T is named explicitly. - -- This info is used when warning of unused names. - - | ImplicitImport -- Imported implicitly for some other reason -\end{code} - -\begin{code} -hasBetterProv :: Provenance -> Provenance -> Bool --- Choose --- a local thing over an imported thing --- a user-imported thing over a non-user-imported thing --- an explicitly-imported thing over an implicitly imported thing -hasBetterProv LocalDef _ = True -hasBetterProv (NonLocalDef (UserImport _ _ _ )) (NonLocalDef ImplicitImport) = True -hasBetterProv _ _ = False - -pprNameProvenance :: GlobalRdrElt -> SDoc -pprNameProvenance (GRE {gre_name = name, gre_prov = prov}) - = case prov of - LocalDef -> ptext SLIT("defined at") <+> ppr (nameSrcLoc name) - NonLocalDef why -> sep [ppr_reason why, - nest 2 (ppr_defn (nameSrcLoc name))] - -ppr_reason ImplicitImport = ptext SLIT("implicitly imported") -ppr_reason (UserImport mod loc _) = ptext SLIT("imported from") <+> ppr mod <+> ptext SLIT("at") <+> ppr loc - -ppr_defn loc | isGoodSrcLoc loc = parens (ptext SLIT("defined at") <+> ppr loc) - | otherwise = empty -\end{code} diff --git a/ghc/compiler/main/Main.hs b/ghc/compiler/main/Main.hs index 1731fa54a8..535cbe41a5 100644 --- a/ghc/compiler/main/Main.hs +++ b/ghc/compiler/main/Main.hs @@ -1,7 +1,7 @@ {-# OPTIONS -fno-warn-incomplete-patterns -optc-DNON_POSIX_SOURCE #-} ----------------------------------------------------------------------------- --- $Id: Main.hs,v 1.133 2003/09/23 14:33:00 simonmar Exp $ +-- $Id: Main.hs,v 1.134 2003/10/09 11:58:57 simonpj Exp $ -- -- GHC Driver program -- @@ -332,9 +332,9 @@ doMake :: [String] -> IO () doMake [] = throwDyn (UsageError "no input files") doMake srcs = do dflags <- getDynFlags - state <- cmInit Batch - graph <- cmDepAnal state dflags srcs - (_, ok_flag, _) <- cmLoadModules state dflags graph + state <- cmInit Batch dflags + graph <- cmDepAnal state srcs + (_, ok_flag, _) <- cmLoadModules state graph when (failed ok_flag) (exitWith (ExitFailure 1)) return () diff --git a/ghc/compiler/main/MkIface.lhs b/ghc/compiler/main/MkIface.lhs deleted file mode 100644 index 9f31e7019b..0000000000 --- a/ghc/compiler/main/MkIface.lhs +++ /dev/null @@ -1,870 +0,0 @@ -% -% (c) The GRASP/AQUA Project, Glasgow University, 1993-1998 -% - -\section[MkIface]{Print an interface for a module} - -\begin{code} -module MkIface ( - showIface, mkIface, mkUsageInfo, - pprIface, - ifaceTyThing, - ) where - -#include "HsVersions.h" - -import HsSyn -import HsCore ( HsIdInfo(..), UfExpr(..), toUfExpr, toUfBndr ) -import HsTypes ( toHsTyVars ) -import TysPrim ( alphaTyVars ) -import BasicTypes ( NewOrData(..), Activation(..), FixitySig(..), - Version, initialVersion, bumpVersion - ) -import NewDemand ( isTopSig ) -import TcRnMonad -import TcRnTypes ( ImportAvails(..) ) -import RnHsSyn ( RenamedInstDecl, RenamedTyClDecl ) -import HscTypes ( VersionInfo(..), ModIface(..), - ModGuts(..), ModGuts, - GhciMode(..), HscEnv(..), Dependencies(..), - FixityEnv, lookupFixity, collectFixities, - IfaceDecls, mkIfaceDecls, dcl_tycl, dcl_rules, dcl_insts, - TyThing(..), DFunId, - Avails, AvailInfo, GenAvailInfo(..), availName, - ExternalPackageState(..), - ParsedIface(..), Usage(..), - Deprecations(..), initialVersionInfo, - lookupVersion, lookupIfaceByModName - ) - -import CmdLineOpts -import Id ( idType, idInfo, isImplicitId, idCafInfo ) -import DataCon ( dataConName, dataConSig, dataConFieldLabels, dataConStrictMarks ) -import IdInfo -- Lots -import CoreSyn ( CoreRule(..), IdCoreRule ) -import CoreFVs ( ruleLhsFreeNames ) -import CoreUnfold ( neverUnfold, unfoldingTemplate ) -import Name ( getName, nameModule, nameModule_maybe, nameOccName, - nameIsLocalOrFrom, Name, NamedThing(..) ) -import NameEnv -import NameSet -import OccName ( OccName, pprOccName ) -import TyCon ( DataConDetails(..), tyConTyVars, tyConDataCons, tyConTheta, - isFunTyCon, isPrimTyCon, isNewTyCon, isClassTyCon, - isSynTyCon, isAlgTyCon, isForeignTyCon, - getSynTyConDefn, tyConGenInfo, tyConDataConDetails, tyConArity ) -import Class ( classExtraBigSig, classTyCon ) -import FieldLabel ( fieldLabelType ) -import TcType ( tcSplitForAllTys, tcFunResultTy, tidyTopType, deNoteType, tyClsNamesOfDFunHead, - mkSigmaTy, mkFunTys, mkTyConApp, mkTyVarTys ) -import SrcLoc ( noSrcLoc ) -import Module ( Module, ModuleName, moduleNameFS, moduleName, isHomeModule, - ModLocation(..), mkSysModuleNameFS, - ModuleEnv, emptyModuleEnv, lookupModuleEnv, - extendModuleEnv_C, moduleEnvElts - ) -import Outputable -import DriverUtil ( createDirectoryHierarchy, directoryOf ) -import Util ( sortLt, dropList, seqList ) -import Binary ( getBinFileWithDict ) -import BinIface ( writeBinIface, v_IgnoreHiVersion ) -import ErrUtils ( dumpIfSet_dyn ) -import FiniteMap -import FastString - -import DATA_IOREF ( writeIORef ) -import Monad ( when ) -import Maybe ( catMaybes, isJust, isNothing ) -import Maybes ( orElse ) -import IO ( putStrLn ) -\end{code} - - -%************************************************************************ -%* * -\subsection{Print out the contents of a binary interface} -%* * -%************************************************************************ - -\begin{code} -showIface :: FilePath -> IO () -showIface filename = do - -- skip the version check; we don't want to worry about profiled vs. - -- non-profiled interfaces, for example. - writeIORef v_IgnoreHiVersion True - parsed_iface <- Binary.getBinFileWithDict filename - let ParsedIface{ - pi_mod=pi_mod, pi_pkg=pi_pkg, pi_vers=pi_vers, - pi_deps=pi_deps, - pi_orphan=pi_orphan, pi_usages=pi_usages, - pi_exports=pi_exports, pi_decls=pi_decls, - pi_fixity=pi_fixity, pi_insts=pi_insts, - pi_rules=pi_rules, pi_deprecs=pi_deprecs } = parsed_iface - putStrLn (showSDoc (vcat [ - text "__interface" <+> doubleQuotes (ppr pi_pkg) - <+> ppr pi_mod <+> ppr pi_vers - <+> (if pi_orphan then char '!' else empty) - <+> ptext SLIT("where"), - -- no instance Outputable (WhatsImported): - pprExports id (snd pi_exports), - pprDeps pi_deps, - pprUsages id pi_usages, - hsep (map ppr_fix pi_fixity) <> semi, - vcat (map ppr_inst pi_insts), - vcat (map ppr_decl pi_decls), - ppr pi_rules - -- no instance Outputable (Either): - -- ppr pi_deprecs - ])) - where - ppr_fix (FixitySig n f _) = ppr f <+> ppr n - ppr_inst i = ppr i <+> semi - ppr_decl (v,d) = int v <+> ppr d <> semi -\end{code} - -%************************************************************************ -%* * -\subsection{Completing an interface} -%* * -%************************************************************************ - -\begin{code} -mkIface :: HscEnv - -> ModLocation - -> Maybe ModIface -- The old interface, if we have it - -> ModGuts -- The compiled, tidied module - -> IO ModIface -- The new one, complete with decls and versions --- mkFinalIface --- a) completes the interface --- b) writes it out to a file if necessary - -mkIface hsc_env location maybe_old_iface - impl@ModGuts{ mg_module = this_mod, - mg_usages = usages, - mg_deps = deps, - mg_exports = exports, - mg_rdr_env = rdr_env, - mg_fix_env = fix_env, - mg_deprecs = deprecs, - mg_insts = insts, - mg_rules = rules, - mg_types = types } - = do { -- Sort the exports to make them easier to compare for versions - let { my_exports = groupAvails this_mod exports ; - - iface_w_decls = ModIface { mi_module = this_mod, - mi_package = opt_InPackage, - mi_version = initialVersionInfo, - mi_deps = deps, - mi_usages = usages, - mi_exports = my_exports, - mi_decls = new_decls, - mi_orphan = orphan_mod, - mi_boot = False, - mi_fixities = fix_env, - mi_globals = Just rdr_env, - mi_deprecs = deprecs } } - - -- Add version information - ; let (final_iface, maybe_diffs) = _scc_ "versioninfo" addVersionInfo maybe_old_iface iface_w_decls - - -- Write the interface file, if necessary - ; when (must_write_hi_file maybe_diffs) $ do - createDirectoryHierarchy (directoryOf hi_file_path) - writeBinIface hi_file_path final_iface - - -- Debug printing - ; write_diffs dflags final_iface maybe_diffs - - ; orphan_mod `seq` - return final_iface } - - where - dflags = hsc_dflags hsc_env - ghci_mode = hsc_mode hsc_env - omit_pragmas = dopt Opt_OmitInterfacePragmas dflags - - must_write_hi_file Nothing = False - must_write_hi_file (Just _diffs) = ghci_mode /= Interactive - -- We must write a new .hi file if there are some changes - -- and we're not in interactive mode - -- maybe_diffs = 'Nothing' means that even the usages havn't changed, - -- so there's no need to write a new interface file. But even if - -- the usages have changed, the module version may not have. - - hi_file_path = ml_hi_file location - new_decls = mkIfaceDecls ty_cls_dcls rule_dcls inst_dcls - inst_dcls = map ifaceInstance insts - ty_cls_dcls = foldNameEnv (ifaceTyThing_acc omit_pragmas) [] types - rule_dcls = map ifaceRule rules - orphan_mod = isOrphanModule impl - -write_diffs :: DynFlags -> ModIface -> Maybe SDoc -> IO () -write_diffs dflags new_iface Nothing - = do when (dopt Opt_D_dump_hi_diffs dflags) (printDump (text "INTERFACE UNCHANGED")) - dumpIfSet_dyn dflags Opt_D_dump_hi "UNCHANGED FINAL INTERFACE" (pprIface new_iface) - -write_diffs dflags new_iface (Just sdoc_diffs) - = do dumpIfSet_dyn dflags Opt_D_dump_hi_diffs "INTERFACE HAS CHANGED" sdoc_diffs - dumpIfSet_dyn dflags Opt_D_dump_hi "NEW FINAL INTERFACE" (pprIface new_iface) -\end{code} - -\begin{code} -isOrphanModule :: ModGuts -> Bool -isOrphanModule (ModGuts {mg_module = this_mod, mg_insts = insts, mg_rules = rules}) - = any orphan_inst insts || any orphan_rule rules - where - -- A rule is an orphan if the LHS mentions nothing defined locally - orphan_inst dfun_id = no_locals (tyClsNamesOfDFunHead (idType dfun_id)) - -- A instance is an orphan if its head mentions nothing defined locally - orphan_rule rule = no_locals (ruleLhsFreeNames rule) - - no_locals names = isEmptyNameSet (filterNameSet (nameIsLocalOrFrom this_mod) names) -\end{code} - -Implicit Ids and class tycons aren't included in interface files, so -we miss them out of the accumulating parameter here. - -\begin{code} -ifaceTyThing_acc :: Bool -> TyThing -> [RenamedTyClDecl] -> [RenamedTyClDecl] --- Don't put implicit things into the result -ifaceTyThing_acc omit_pragmas (ADataCon dc) so_far = so_far -ifaceTyThing_acc omit_pragmas (AnId id) so_far | isImplicitId id = so_far -ifaceTyThing_acc omit_pragmas (ATyCon id) so_far | isClassTyCon id = so_far -ifaceTyThing_acc omit_pragmas other so_far - = ifaceTyThing omit_pragmas other : so_far -\end{code} - -Convert *any* TyThing into a RenamedTyClDecl. Used both for -generating interface files and for the ':info' command in GHCi. - -\begin{code} -ifaceTyThing :: Bool -> TyThing -> RenamedTyClDecl -ifaceTyThing omit_pragmas (AClass clas) = cls_decl - where - cls_decl = ClassDecl { tcdCtxt = toHsContext sc_theta, - tcdName = getName clas, - tcdTyVars = toHsTyVars clas_tyvars, - tcdFDs = toHsFDs clas_fds, - tcdSigs = map toClassOpSig op_stuff, - tcdMeths = Nothing, - tcdLoc = noSrcLoc } - - (clas_tyvars, clas_fds, sc_theta, sc_sels, op_stuff) = classExtraBigSig clas - tycon = classTyCon clas - data_con = head (tyConDataCons tycon) - - toClassOpSig (sel_id, def_meth) - = ASSERT(sel_tyvars == clas_tyvars) - ClassOpSig (getName sel_id) def_meth (toHsType op_ty) noSrcLoc - where - -- Be careful when splitting the type, because of things - -- like class Foo a where - -- op :: (?x :: String) => a -> a - -- and class Baz a where - -- op :: (Ord a) => a -> a - (sel_tyvars, rho_ty) = tcSplitForAllTys (idType sel_id) - op_ty = tcFunResultTy rho_ty - -ifaceTyThing omit_pragmas (ATyCon tycon) = ty_decl - where - ty_decl | isSynTyCon tycon - = TySynonym { tcdName = getName tycon, - tcdTyVars = toHsTyVars tyvars, - tcdSynRhs = toHsType syn_ty, - tcdLoc = noSrcLoc } - - | isAlgTyCon tycon - = TyData { tcdND = new_or_data, - tcdCtxt = toHsContext (tyConTheta tycon), - tcdName = getName tycon, - tcdTyVars = toHsTyVars tyvars, - tcdCons = ifaceConDecls (tyConDataConDetails tycon), - tcdDerivs = Nothing, - tcdGeneric = Just (isJust (tyConGenInfo tycon)), - -- Just True <=> has generic stuff - tcdLoc = noSrcLoc } - - | isForeignTyCon tycon - = ForeignType { tcdName = getName tycon, - tcdExtName = Nothing, - tcdFoType = DNType, -- The only case at present - tcdLoc = noSrcLoc } - - | isPrimTyCon tycon || isFunTyCon tycon - -- needed in GHCi for ':info Int#', for example - = TyData { tcdND = DataType, - tcdCtxt = [], - tcdName = getName tycon, - tcdTyVars = toHsTyVars (take (tyConArity tycon) alphaTyVars), - tcdCons = Unknown, - tcdDerivs = Nothing, - tcdGeneric = Just False, - tcdLoc = noSrcLoc } - - | otherwise = pprPanic "ifaceTyThing" (ppr tycon) - - tyvars = tyConTyVars tycon - (_, syn_ty) = getSynTyConDefn tycon - new_or_data | isNewTyCon tycon = NewType - | otherwise = DataType - - ifaceConDecls Unknown = Unknown - ifaceConDecls (HasCons n) = HasCons n - ifaceConDecls (DataCons cs) = DataCons (map ifaceConDecl cs) - - ifaceConDecl data_con - = ConDecl (dataConName data_con) - (toHsTyVars ex_tyvars) - (toHsContext ex_theta) - details noSrcLoc - where - (tyvars1, _, ex_tyvars, ex_theta, arg_tys, tycon1) = dataConSig data_con - field_labels = dataConFieldLabels data_con - strict_marks = dropList ex_theta (dataConStrictMarks data_con) - -- The 'drop' is because dataConStrictMarks - -- includes the existential dictionaries - details | null field_labels - = ASSERT( tycon == tycon1 && tyvars == tyvars1 ) - PrefixCon (zipWith BangType strict_marks (map toHsType arg_tys)) - - | otherwise - = RecCon (zipWith mk_field strict_marks field_labels) - - mk_field strict_mark field_label - = (getName field_label, BangType strict_mark (toHsType (fieldLabelType field_label))) - -ifaceTyThing omit_pragmas (AnId id) = iface_sig - where - iface_sig = IfaceSig { tcdName = getName id, - tcdType = toHsType id_type, - tcdIdInfo = hs_idinfo, - tcdLoc = noSrcLoc } - - id_type = idType id - id_info = idInfo id - arity_info = arityInfo id_info - caf_info = idCafInfo id - - hs_idinfo | omit_pragmas - = [] - | otherwise - = catMaybes [arity_hsinfo, caf_hsinfo, - strict_hsinfo, wrkr_hsinfo, - unfold_hsinfo] - - ------------ Arity -------------- - arity_hsinfo | arity_info == 0 = Nothing - | otherwise = Just (HsArity arity_info) - - ------------ Caf Info -------------- - caf_hsinfo = case caf_info of - NoCafRefs -> Just HsNoCafRefs - _other -> Nothing - - ------------ Strictness -------------- - -- No point in explicitly exporting TopSig - strict_hsinfo = case newStrictnessInfo id_info of - Just sig | not (isTopSig sig) -> Just (HsStrictness sig) - _other -> Nothing - - ------------ Worker -------------- - work_info = workerInfo id_info - has_worker = case work_info of { HasWorker _ _ -> True; other -> False } - wrkr_hsinfo = case work_info of - HasWorker work_id wrap_arity -> - Just (HsWorker (getName work_id) wrap_arity) - NoWorker -> Nothing - - ------------ Unfolding -------------- - -- The unfolding is redundant if there is a worker - unfold_info = unfoldingInfo id_info - inline_prag = inlinePragInfo id_info - rhs = unfoldingTemplate unfold_info - unfold_hsinfo | neverUnfold unfold_info - || has_worker = Nothing - | otherwise = Just (HsUnfold inline_prag (toUfExpr rhs)) - - -ifaceTyThing omit_pragmas (ADataCon dc) - -- This case only happens in the call to ifaceThing in InteractiveUI - -- Otherwise DataCons are filtered out in ifaceThing_acc - = IfaceSig { tcdName = getName dc, - tcdType = toHsType full_ty, - tcdIdInfo = [], - tcdLoc = noSrcLoc } - where - (tvs, stupid_theta, ex_tvs, ex_theta, arg_tys, tycon) = dataConSig dc - - -- The "stupid context" isn't part of the wrapper-Id type - -- (for better or worse -- see note in DataCon.lhs), so we - -- have to make it up here - full_ty = mkSigmaTy (tvs ++ ex_tvs) (stupid_theta ++ ex_theta) - (mkFunTys arg_tys (mkTyConApp tycon (mkTyVarTys tvs))) -\end{code} - -\begin{code} -ifaceInstance :: DFunId -> RenamedInstDecl -ifaceInstance dfun_id - = InstDecl (toHsType tidy_ty) EmptyMonoBinds [] (Just (getName dfun_id)) noSrcLoc - where - tidy_ty = tidyTopType (deNoteType (idType dfun_id)) - -- The deNoteType is very important. It removes all type - -- synonyms from the instance type in interface files. - -- That in turn makes sure that when reading in instance decls - -- from interface files that the 'gating' mechanism works properly. - -- Otherwise you could have - -- type Tibble = T Int - -- instance Foo Tibble where ... - -- and this instance decl wouldn't get imported into a module - -- that mentioned T but not Tibble. - -ifaceRule :: IdCoreRule -> RuleDecl Name -ifaceRule (id, BuiltinRule _ _) - = pprTrace "toHsRule: builtin" (ppr id) (bogusIfaceRule id) - -ifaceRule (id, Rule name act bndrs args rhs) - = IfaceRule name act (map toUfBndr bndrs) (getName id) - (map toUfExpr args) (toUfExpr rhs) noSrcLoc - -bogusIfaceRule :: (NamedThing a) => a -> RuleDecl Name -bogusIfaceRule id - = IfaceRule FSLIT("bogus") NeverActive [] (getName id) [] (UfVar (getName id)) noSrcLoc -\end{code} - - -%********************************************************* -%* * -\subsection{Keeping track of what we've slurped, and version numbers} -%* * -%********************************************************* - -mkUsageInfo figures out what the ``usage information'' for this -moudule is; that is, what it must record in its interface file as the -things it uses. - -We produce a line for every module B below the module, A, currently being -compiled: - import B <n> ; -to record the fact that A does import B indirectly. This is used to decide -to look to look for B.hi rather than B.hi-boot when compiling a module that -imports A. This line says that A imports B, but uses nothing in it. -So we'll get an early bale-out when compiling A if B's version changes. - -The usage information records: - -\begin{itemize} -\item (a) anything reachable from its body code -\item (b) any module exported with a @module Foo@ -\item (c) anything reachable from an exported item -\end{itemize} - -Why (b)? Because if @Foo@ changes then this module's export list -will change, so we must recompile this module at least as far as -making a new interface file --- but in practice that means complete -recompilation. - -Why (c)? Consider this: -\begin{verbatim} - module A( f, g ) where | module B( f ) where - import B( f ) | f = h 3 - g = ... | h = ... -\end{verbatim} - -Here, @B.f@ isn't used in A. Should we nevertheless record @B.f@ in -@A@'s usages? Our idea is that we aren't going to touch A.hi if it is -*identical* to what it was before. If anything about @B.f@ changes -than anyone who imports @A@ should be recompiled in case they use -@B.f@ (they'll get an early exit if they don't). So, if anything -about @B.f@ changes we'd better make sure that something in A.hi -changes, and the convenient way to do that is to record the version -number @B.f@ in A.hi in the usage list. If B.f changes that'll force a -complete recompiation of A, which is overkill but it's the only way to -write a new, slightly different, A.hi. - -But the example is tricker. Even if @B.f@ doesn't change at all, -@B.h@ may do so, and this change may not be reflected in @f@'s version -number. But with -O, a module that imports A must be recompiled if -@B.h@ changes! So A must record a dependency on @B.h@. So we treat -the occurrence of @B.f@ in the export list *just as if* it were in the -code of A, and thereby haul in all the stuff reachable from it. - - *** Conclusion: if A mentions B.f in its export list, - behave just as if A mentioned B.f in its source code, - and slurp in B.f and all its transitive closure *** - -[NB: If B was compiled with -O, but A isn't, we should really *still* -haul in all the unfoldings for B, in case the module that imports A *is* -compiled with -O. I think this is the case.] - -\begin{code} -mkUsageInfo :: HscEnv -> ExternalPackageState - -> ImportAvails -> EntityUsage - -> [Usage Name] - -mkUsageInfo hsc_env eps - (ImportAvails { imp_mods = dir_imp_mods, - imp_dep_mods = dep_mods }) - used_names - = -- seq the list of Usages returned: occasionally these - -- don't get evaluated for a while and we can end up hanging on to - -- the entire collection of Ifaces. - usages `seqList` usages - where - usages = catMaybes [ mkUsage mod_name - | (mod_name,_) <- moduleEnvElts dep_mods] - -- ToDo: do we need to sort into canonical order? - - hpt = hsc_HPT hsc_env - pit = eps_PIT eps - - import_all mod = case lookupModuleEnv dir_imp_mods mod of - Just (_, Nothing) -> True - _ -> False - - -- ent_map groups together all the things imported and used - -- from a particular module in this package - ent_map :: ModuleEnv [Name] - ent_map = foldNameSet add_mv emptyModuleEnv used_names - add_mv name mv_map = extendModuleEnv_C add_item mv_map mod [name] - where - mod = nameModule name - add_item names _ = name:names - - -- We want to create a Usage for a home module if - -- a) we used something from; has something in used_names - -- b) we imported all of it, even if we used nothing from it - -- (need to recompile if its export list changes: export_vers) - -- c) is a home-package orphan module (need to recompile if its - -- instance decls change: rules_vers) - mkUsage :: ModuleName -> Maybe (Usage Name) - mkUsage mod_name - | isNothing maybe_iface -- We can't depend on it if we didn't - || not (isHomeModule mod) -- even open the interface! - || (null used_names - && not all_imported - && not orphan_mod) - = Nothing -- Record no usage info - - | otherwise - = Just (Usage { usg_name = moduleName mod, - usg_mod = mod_vers, - usg_exports = export_vers, - usg_entities = ent_vers, - usg_rules = rules_vers }) - where - maybe_iface = lookupIfaceByModName hpt pit mod_name - -- In one-shot mode, the interfaces for home-package - -- modules accumulate in the PIT not HPT. Sigh. - - Just iface = maybe_iface - mod = mi_module iface - version_info = mi_version iface - orphan_mod = mi_orphan iface - version_env = vers_decls version_info - mod_vers = vers_module version_info - rules_vers = vers_rules version_info - all_imported = import_all mod - export_vers | all_imported = Just (vers_exports version_info) - | otherwise = Nothing - - -- The sort is to put them into canonical order - used_names = lookupModuleEnv ent_map mod `orElse` [] - ent_vers = [(n, lookupVersion version_env n) - | n <- sortLt lt_occ used_names ] - lt_occ n1 n2 = nameOccName n1 < nameOccName n2 - -- ToDo: is '<' on OccNames the right thing; may differ between runs? -\end{code} - -\begin{code} -groupAvails :: Module -> Avails -> [(ModuleName, Avails)] - -- Group by module and sort by occurrence - -- This keeps the list in canonical order -groupAvails this_mod avails - = [ (mkSysModuleNameFS fs, sortLt lt avails) - | (fs,avails) <- fmToList groupFM - ] - where - groupFM :: FiniteMap FastString Avails - -- Deliberately use the FastString so we - -- get a canonical ordering - groupFM = foldl add emptyFM avails - - add env avail = addToFM_C combine env mod_fs [avail'] - where - mod_fs = moduleNameFS (moduleName avail_mod) - avail_mod = case nameModule_maybe (availName avail) of - Just m -> m - Nothing -> this_mod - combine old _ = avail':old - avail' = sortAvail avail - - a1 `lt` a2 = occ1 < occ2 - where - occ1 = nameOccName (availName a1) - occ2 = nameOccName (availName a2) - -sortAvail :: AvailInfo -> AvailInfo --- Sort the sub-names into canonical order. --- The canonical order has the "main name" at the beginning --- (if it's there at all) -sortAvail (Avail n) = Avail n -sortAvail (AvailTC n ns) | n `elem` ns = AvailTC n (n : sortLt lt (filter (/= n) ns)) - | otherwise = AvailTC n ( sortLt lt ns) - where - n1 `lt` n2 = nameOccName n1 < nameOccName n2 -\end{code} - -%************************************************************************ -%* * -\subsection{Checking if the new interface is up to date -%* * -%************************************************************************ - -\begin{code} -addVersionInfo :: Maybe ModIface -- The old interface, read from M.hi - -> ModIface -- The new interface decls - -> (ModIface, Maybe SDoc) -- Nothing => no change; no need to write new Iface - -- Just mi => Here is the new interface to write - -- with correct version numbers - --- NB: the fixities, declarations, rules are all assumed --- to be sorted by increasing order of hsDeclName, so that --- we can compare for equality - -addVersionInfo Nothing new_iface --- No old interface, so definitely write a new one! - = (new_iface, Just (text "No old interface available")) - -addVersionInfo (Just old_iface@(ModIface { mi_version = old_version, - mi_decls = old_decls, - mi_fixities = old_fixities, - mi_deprecs = old_deprecs })) - new_iface@(ModIface { mi_decls = new_decls, - mi_fixities = new_fixities, - mi_deprecs = new_deprecs }) - - | no_output_change && no_usage_change - = (new_iface, Nothing) - -- don't return the old iface because it may not have an - -- mi_globals field set to anything reasonable. - - | otherwise -- Add updated version numbers - = --pprTrace "completeIface" (ppr (dcl_tycl old_decls)) - (final_iface, Just pp_diffs) - - where - final_iface = new_iface { mi_version = new_version } - old_mod_vers = vers_module old_version - new_version = VersionInfo { vers_module = bumpVersion no_output_change old_mod_vers, - vers_exports = bumpVersion no_export_change (vers_exports old_version), - vers_rules = bumpVersion no_rule_change (vers_rules old_version), - vers_decls = tc_vers } - - no_output_change = no_tc_change && no_rule_change && no_export_change && no_deprec_change - no_usage_change = mi_usages old_iface == mi_usages new_iface - - no_export_change = mi_exports old_iface == mi_exports new_iface -- Kept sorted - no_rule_change = dcl_rules old_decls == dcl_rules new_decls -- Ditto - && dcl_insts old_decls == dcl_insts new_decls - no_deprec_change = old_deprecs == new_deprecs - - -- Fill in the version number on the new declarations by looking at the old declarations. - -- Set the flag if anything changes. - -- Assumes that the decls are sorted by hsDeclName. - (no_tc_change, pp_tc_diffs, tc_vers) = diffDecls old_version old_fixities new_fixities - (dcl_tycl old_decls) (dcl_tycl new_decls) - pp_diffs = vcat [pp_tc_diffs, - pp_change no_export_change "Export list", - pp_change no_rule_change "Rules", - pp_change no_deprec_change "Deprecations", - pp_change no_usage_change "Usages"] - pp_change True what = empty - pp_change False what = text what <+> ptext SLIT("changed") - -diffDecls :: VersionInfo -- Old version - -> FixityEnv -> FixityEnv -- Old and new fixities - -> [RenamedTyClDecl] -> [RenamedTyClDecl] -- Old and new decls - -> (Bool, -- True <=> no change - SDoc, -- Record of differences - NameEnv Version) -- New version map - -diffDecls (VersionInfo { vers_module = old_mod_vers, vers_decls = old_decls_vers }) - old_fixities new_fixities old new - = diff True empty emptyNameEnv old new - where - -- When seeing if two decls are the same, - -- remember to check whether any relevant fixity has changed - eq_tc d1 d2 = d1 == d2 && all (same_fixity . fst) (tyClDeclNames d1) - same_fixity n = lookupFixity old_fixities n == lookupFixity new_fixities n - - diff ok_so_far pp new_vers [] [] = (ok_so_far, pp, new_vers) - diff ok_so_far pp new_vers (od:ods) [] = diff False (pp $$ only_old od) new_vers ods [] - diff ok_so_far pp new_vers [] (nd:nds) = diff False (pp $$ only_new nd) new_vers_with_new [] nds - where - new_vers_with_new = extendNameEnv new_vers (tyClDeclName nd) (bumpVersion False old_mod_vers) - -- When adding a new item, start from the old module version - -- This way, if you have version 4 of f, then delete f, then add f again, - -- you'll get version 6 of f, which will (correctly) force recompilation of - -- clients - - diff ok_so_far pp new_vers (od:ods) (nd:nds) - = case od_name `compare` nd_name of - LT -> diff False (pp $$ only_old od) new_vers ods (nd:nds) - GT -> diff False (pp $$ only_new nd) new_vers (od:ods) nds - EQ | od `eq_tc` nd -> diff ok_so_far pp new_vers ods nds - | otherwise -> diff False (pp $$ changed od nd) new_vers_with_diff ods nds - where - od_name = tyClDeclName od - nd_name = tyClDeclName nd - new_vers_with_diff = extendNameEnv new_vers nd_name (bumpVersion False old_version) - old_version = lookupVersion old_decls_vers od_name - - only_old d = ptext SLIT("Only in old iface:") <+> ppr d - only_new d = ptext SLIT("Only in new iface:") <+> ppr d - changed od nd = ptext SLIT("Changed in iface: ") <+> ((ptext SLIT("Old:") <+> ppr od) $$ - (ptext SLIT("New:") <+> ppr nd)) -\end{code} - - -b%************************************************************************ -%* * -\subsection{Writing an interface file} -%* * -%************************************************************************ - -\begin{code} -pprIface :: ModIface -> SDoc -pprIface iface - = vcat [ ptext SLIT("__interface") - <+> doubleQuotes (ftext (mi_package iface)) - <+> ppr (mi_module iface) <+> ppr (vers_module version_info) - <+> pp_sub_vers - <+> (if mi_orphan iface then char '!' else empty) - <+> int opt_HiVersion - <+> ptext SLIT("where") - - , pprExports nameOccName (mi_exports iface) - , pprDeps (mi_deps iface) - , pprUsages nameOccName (mi_usages iface) - - , pprFixities (mi_fixities iface) (dcl_tycl decls) - , pprIfaceDecls (vers_decls version_info) decls - , pprRulesAndDeprecs (dcl_rules decls) (mi_deprecs iface) - ] - where - version_info = mi_version iface - decls = mi_decls iface - exp_vers = vers_exports version_info - - rule_vers = vers_rules version_info - - pp_sub_vers | exp_vers == initialVersion && rule_vers == initialVersion = empty - | otherwise = brackets (ppr exp_vers <+> ppr rule_vers) -\end{code} - -When printing export lists, we print like this: - Avail f f - AvailTC C [C, x, y] C(x,y) - AvailTC C [x, y] C!(x,y) -- Exporting x, y but not C - -\begin{code} -pprExports :: Eq a => (a -> OccName) -> [(ModuleName, [GenAvailInfo a])] -> SDoc -pprExports getOcc exports = vcat (map (pprExport getOcc) exports) - -pprExport :: Eq a => (a -> OccName) -> (ModuleName, [GenAvailInfo a]) -> SDoc -pprExport getOcc (mod, items) - = hsep [ ptext SLIT("__export "), ppr mod, hsep (map pp_avail items) ] <> semi - where - --pp_avail :: GenAvailInfo a -> SDoc - pp_avail (Avail name) = ppr (getOcc name) - pp_avail (AvailTC _ []) = empty - pp_avail (AvailTC n (n':ns)) - | n==n' = ppr (getOcc n) <> pp_export ns - | otherwise = ppr (getOcc n) <> char '|' <> pp_export (n':ns) - - pp_export [] = empty - pp_export names = braces (hsep (map (ppr.getOcc) names)) - -pprOcc :: Name -> SDoc -- Print the occurrence name only -pprOcc n = pprOccName (nameOccName n) -\end{code} - - -\begin{code} -pprUsages :: (a -> OccName) -> [Usage a] -> SDoc -pprUsages getOcc usages = vcat (map (pprUsage getOcc) usages) - -pprUsage :: (a -> OccName) -> Usage a -> SDoc -pprUsage getOcc usage - = hsep [ptext SLIT("import"), ppr (usg_name usage), - int (usg_mod usage), - pp_export_version (usg_exports usage), - int (usg_rules usage), - pp_versions (usg_entities usage) - ] <> semi - where - pp_versions nvs = hsep [ ppr (getOcc n) <+> int v | (n,v) <- nvs ] - - pp_export_version Nothing = empty - pp_export_version (Just v) = int v - - -pprDeps :: Dependencies -> SDoc -pprDeps (Deps { dep_mods = mods, dep_pkgs = pkgs, dep_orphs = orphs}) - = vcat [ptext SLIT("module dependencies:") <+> fsep (map ppr_mod mods), - ptext SLIT("package dependencies:") <+> fsep (map ppr pkgs), - ptext SLIT("orphans:") <+> fsep (map ppr orphs) - ] - where - ppr_mod (mod_name, boot) = ppr mod_name <+> ppr_boot boot - - ppr_boot True = text "[boot]" - ppr_boot False = empty -\end{code} - -\begin{code} -pprIfaceDecls :: NameEnv Int -> IfaceDecls -> SDoc -pprIfaceDecls version_map decls - = vcat [ vcat [ppr i <+> semi | i <- dcl_insts decls] - , vcat (map ppr_decl (dcl_tycl decls)) - ] - where - ppr_decl d = ppr_vers d <+> ppr d <> semi - - -- Print the version for the decl - ppr_vers d = case lookupNameEnv version_map (tyClDeclName d) of - Nothing -> empty - Just v -> int v -\end{code} - -\begin{code} -pprFixities :: FixityEnv - -> [TyClDecl Name] - -> SDoc -pprFixities fixity_map decls - = hsep [ ppr fix <+> ppr n - | FixitySig n fix _ <- collectFixities fixity_map decls ] <> semi - --- Disgusting to print these two together, but that's --- the way the interface parser currently expects them. -pprRulesAndDeprecs :: (Outputable a) => [a] -> Deprecations -> SDoc -pprRulesAndDeprecs [] NoDeprecs = empty -pprRulesAndDeprecs rules deprecs - = ptext SLIT("{-##") <+> (pp_rules rules $$ pp_deprecs deprecs) <+> ptext SLIT("##-}") - where - pp_rules [] = empty - pp_rules rules = ptext SLIT("__R") <+> vcat (map ppr rules) - - pp_deprecs NoDeprecs = empty - pp_deprecs deprecs = ptext SLIT("__D") <+> guts - where - guts = case deprecs of - DeprecAll txt -> doubleQuotes (ftext txt) - DeprecSome env -> ppr_deprec_env env - -ppr_deprec_env :: NameEnv (Name, FastString) -> SDoc -ppr_deprec_env env = vcat (punctuate semi (map pp_deprec (nameEnvElts env))) - where - pp_deprec (name, txt) = pprOcc name <+> doubleQuotes (ftext txt) -\end{code} diff --git a/ghc/compiler/main/ParsePkgConf.y b/ghc/compiler/main/ParsePkgConf.y index cfecbca2a6..abbbcea1eb 100644 --- a/ghc/compiler/main/ParsePkgConf.y +++ b/ghc/compiler/main/ParsePkgConf.y @@ -98,8 +98,8 @@ loadPackageConfig conf_filename = do buf <- hGetStringBuffer conf_filename let loc = mkSrcLoc (mkFastString conf_filename) 1 0 case unP parse (mkPState buf loc defaultDynFlags) of - PFailed l1 l2 err -> do - throwDyn (InstallationError (showPFailed l1 l2 err)) + PFailed l1 l2 err -> + throwDyn (InstallationError (showSDoc (showPFailed l1 l2 err))) POk _ pkg_details -> do return pkg_details diff --git a/ghc/compiler/main/TidyPgm.lhs b/ghc/compiler/main/TidyPgm.lhs index 61b5b8ecc4..aaedea479b 100644 --- a/ghc/compiler/main/TidyPgm.lhs +++ b/ghc/compiler/main/TidyPgm.lhs @@ -8,7 +8,7 @@ module TidyPgm( tidyCorePgm, tidyCoreExpr ) where #include "HsVersions.h" -import CmdLineOpts ( DynFlags, DynFlag(..), dopt ) +import CmdLineOpts ( DynFlag(..), dopt ) import CoreSyn import CoreUnfold ( noUnfolding, mkTopUnfolding ) import CoreFVs ( ruleLhsFreeIds, ruleRhsFreeVars, exprSomeFreeVars ) @@ -26,16 +26,15 @@ import Id ( idType, idInfo, idName, idCoreRules, import IdInfo {- loads of stuff -} import NewDemand ( isBottomingSig, topSig ) import BasicTypes ( Arity, isNeverActive ) -import Name ( getOccName, nameOccName, mkInternalName, - localiseName, isExternalName, nameSrcLoc +import Name ( Name, getOccName, nameOccName, mkInternalName, + localiseName, isExternalName, nameSrcLoc, nameParent_maybe ) -import RnEnv ( lookupOrigNameCache, newExternalName ) +import IfaceEnv ( allocateGlobalBinder ) import NameEnv ( lookupNameEnv, filterNameEnv ) import OccName ( TidyOccEnv, initTidyOccEnv, tidyOccName ) import Type ( tidyTopType ) import Module ( Module ) -import HscTypes ( PersistentCompilerState( pcs_nc ), - NameCache( nsNames, nsUniqs ), +import HscTypes ( HscEnv(..), NameCache( nsUniqs ), TypeEnv, extendTypeEnvList, typeEnvIds, ModGuts(..), ModGuts, TyThing(..) ) @@ -44,9 +43,9 @@ import ErrUtils ( showPass, dumpIfSet_core ) import UniqFM ( mapUFM ) import UniqSupply ( splitUniqSupply, uniqFromSupply ) import List ( partition ) -import Util ( mapAccumL ) import Maybe ( isJust ) import Outputable +import DATA_IOREF ( IORef, readIORef, writeIORef ) import FastTypes hiding ( fastOr ) \end{code} @@ -86,7 +85,7 @@ binder [Even non-exported things need system-wide Uniques because the byte-code generator builds a single Name->BCO symbol table.] - We use the NameCache kept in the PersistentCompilerState as the + We use the NameCache kept in the HscEnv as the source of such system-wide uniques. For external Ids, use the original-name cache in the NameCache @@ -118,16 +117,15 @@ throughout, including in unfoldings. We also tidy binders in RHSs, so that they print nicely in interfaces. \begin{code} -tidyCorePgm :: DynFlags - -> PersistentCompilerState - -> ModGuts - -> IO (PersistentCompilerState, ModGuts) +tidyCorePgm :: HscEnv -> ModGuts -> IO ModGuts -tidyCorePgm dflags pcs +tidyCorePgm hsc_env mod_impl@(ModGuts { mg_module = mod, mg_types = env_tc, mg_insts = insts_tc, mg_binds = binds_in, mg_rules = orphans_in }) - = do { showPass dflags "Tidy Core" + = do { let { dflags = hsc_dflags hsc_env + ; nc_var = hsc_NC hsc_env } + ; showPass dflags "Tidy Core" ; let omit_iface_prags = dopt Opt_OmitInterfacePragmas dflags ; let ext_ids = findExternalSet omit_iface_prags binds_in orphans_in @@ -146,9 +144,8 @@ tidyCorePgm dflags pcs -- The second exported decl must 'get' the name 'f', so we -- have to put 'f' in the avoids list before we get to the first -- decl. tidyTopId then does a no-op on exported binders. - ; let orig_ns = pcs_nc pcs - init_tidy_env = (orig_ns, initTidyOccEnv avoids, emptyVarEnv) - avoids = [getOccName name | bndr <- typeEnvIds env_tc, + ; let init_env = (initTidyOccEnv avoids, emptyVarEnv) + avoids = [getOccName name | bndr <- typeEnvIds env_tc, let name = idName bndr, isExternalName name] -- In computing our "avoids" list, we must include @@ -158,13 +155,10 @@ tidyCorePgm dflags pcs -- since their names are "taken". -- The type environment is a convenient source of such things. - ; let ((orig_ns', occ_env, subst_env), tidy_binds) - = mapAccumL (tidyTopBind mod ext_ids) - init_tidy_env binds_in + ; (final_env, tidy_binds) + <- tidyTopBinds mod nc_var ext_ids init_env binds_in - ; let tidy_rules = tidyIdRules (occ_env,subst_env) ext_rules - - ; let pcs' = pcs { pcs_nc = orig_ns' } + ; let tidy_rules = tidyIdRules final_env ext_rules ; let tidy_type_env = mkFinalTypeEnv omit_iface_prags env_tc tidy_binds @@ -173,7 +167,8 @@ tidyCorePgm dflags pcs -- to lookup the id in the TypeEnv too, because -- those Ids have had their IdInfo stripped if -- necessary. - ; let lookup_dfun_id id = + ; let (_, subst_env ) = final_env + lookup_dfun_id id = case lookupVarEnv subst_env id of Nothing -> dfun_panic Just id -> @@ -195,7 +190,7 @@ tidyCorePgm dflags pcs "Tidy Core Rules" (pprIdRules tidy_rules) - ; return (pcs', tidy_result) + ; return tidy_result } tidyCoreExpr :: CoreExpr -> IO CoreExpr @@ -220,7 +215,7 @@ mkFinalTypeEnv :: Bool -- Omit interface pragmas -- b) removing all Ids, -- c) adding Ids with correct IdInfo, including unfoldings, -- gotten from the bindings --- From (c) we keep only those Ids with Global names; +-- From (c) we keep only those Ids with External names; -- the CoreTidy pass makes sure these are all and only -- the externally-accessible ones -- This truncates the type environment to include only the @@ -397,10 +392,8 @@ addExternal omit_iface_prags (id,rhs) needed \begin{code} -type TopTidyEnv = (NameCache, TidyOccEnv, VarEnv Var) - -- TopTidyEnv: when tidying we need to know --- * ns: The NameCache, containing a unique supply and any pre-ordained Names. +-- * nc_var: The NameCache, containing a unique supply and any pre-ordained Names. -- These may have arisen because the -- renamer read in an interface file mentioning M.$wf, say, -- and assigned it unique r77. If, on this compilation, we've @@ -412,91 +405,151 @@ type TopTidyEnv = (NameCache, TidyOccEnv, VarEnv Var) -- are 'used' -- -- * subst_env: A Var->Var mapping that substitutes the new Var for the old -\end{code} +tidyTopBinds :: Module + -> IORef NameCache -- For allocating new unique names + -> IdEnv Bool -- Domain = Ids that should be external + -- True <=> their unfolding is external too + -> TidyEnv -> [CoreBind] + -> IO (TidyEnv, [CoreBind]) +tidyTopBinds mod nc_var ext_ids tidy_env [] + = return (tidy_env, []) -\begin{code} +tidyTopBinds mod nc_var ext_ids tidy_env (b:bs) + = do { (tidy_env1, b') <- tidyTopBind mod nc_var ext_ids tidy_env b + ; (tidy_env2, bs') <- tidyTopBinds mod nc_var ext_ids tidy_env1 bs + ; return (tidy_env2, b':bs') } + +------------------------ tidyTopBind :: Module - -> IdEnv Bool -- Domain = Ids that should be external + -> IORef NameCache -- For allocating new unique names + -> IdEnv Bool -- Domain = Ids that should be external -- True <=> their unfolding is external too - -> TopTidyEnv -> CoreBind - -> (TopTidyEnv, CoreBind) - -tidyTopBind mod ext_ids top_tidy_env@(_,_,subst1) (NonRec bndr rhs) - = ((orig,occ,subst) , NonRec bndr' rhs') + -> TidyEnv -> CoreBind + -> IO (TidyEnv, CoreBind) + +tidyTopBind mod nc_var ext_ids tidy_env1@(occ_env1,subst1) (NonRec bndr rhs) + = do { (occ_env2, name') <- tidyTopName mod nc_var ext_ids occ_env1 bndr + ; let { (bndr', rhs') = tidyTopPair ext_ids tidy_env2 caf_info name' (bndr, rhs) + ; subst2 = extendVarEnv subst1 bndr bndr' + ; tidy_env2 = (occ_env2, subst2) } + ; return (tidy_env2, NonRec bndr' rhs') } where - ((orig,occ,subst), bndr') - = tidyTopBinder mod ext_ids caf_info - rec_tidy_env rhs rhs' top_tidy_env bndr - rec_tidy_env = (occ,subst) - rhs' = tidyExpr rec_tidy_env rhs - caf_info = hasCafRefs subst1 (idArity bndr') rhs' - -tidyTopBind mod ext_ids top_tidy_env@(_,_,subst1) (Rec prs) - = (final_env, Rec prs') + caf_info = hasCafRefs subst1 (idArity bndr) rhs + +tidyTopBind mod nc_var ext_ids tidy_env1@(occ_env1,subst1) (Rec prs) + = do { (occ_env2, names') <- tidyTopNames mod nc_var ext_ids occ_env1 bndrs + ; let { prs' = zipWith (tidyTopPair ext_ids tidy_env2 caf_info) + names' prs + ; subst2 = extendVarEnvList subst1 (bndrs `zip` map fst prs') + ; tidy_env2 = (occ_env2, subst2) } + ; return (tidy_env2, Rec prs') } where - (final_env@(_,occ,subst), prs') = mapAccumL do_one top_tidy_env prs - rec_tidy_env = (occ,subst) - - do_one top_tidy_env (bndr,rhs) - = ((orig,occ,subst), (bndr',rhs')) - where - ((orig,occ,subst), bndr') - = tidyTopBinder mod ext_ids caf_info - rec_tidy_env rhs rhs' top_tidy_env bndr - - rhs' = tidyExpr rec_tidy_env rhs + bndrs = map fst prs -- the CafInfo for a recursive group says whether *any* rhs in -- the group may refer indirectly to a CAF (because then, they all do). caf_info | or [ mayHaveCafRefs (hasCafRefs subst1 (idArity bndr) rhs) | (bndr,rhs) <- prs ] = MayHaveCafRefs - | otherwise = NoCafRefs - -tidyTopBinder :: Module -> IdEnv Bool -> CafInfo - -> TidyEnv -- The TidyEnv is used to tidy the IdInfo - -> CoreExpr -- RHS *before* tidying - -> CoreExpr -- RHS *after* tidying - -- The TidyEnv and the after-tidying RHS are - -- both are knot-tied: don't look at them! - -> TopTidyEnv -> Id -> (TopTidyEnv, Id) - -- NB: tidyTopBinder doesn't affect the unique supply - -tidyTopBinder mod ext_ids caf_info rec_tidy_env rhs tidy_rhs - env@(ns2, occ_env2, subst_env2) id + | otherwise = NoCafRefs + +-------------------------------------------------------------------- +-- tidyTopName +-- This is where we set names to local/global based on whether they really are +-- externally visible (see comment at the top of this module). If the name +-- was previously local, we have to give it a unique occurrence name if +-- we intend to externalise it. +tidyTopNames mod nc_var ext_ids occ_env [] = return (occ_env, []) +tidyTopNames mod nc_var ext_ids occ_env (id:ids) + = do { (occ_env1, name) <- tidyTopName mod nc_var ext_ids occ_env id + ; (occ_env2, names) <- tidyTopNames mod nc_var ext_ids occ_env1 ids + ; return (occ_env2, name:names) } + +tidyTopName :: Module -> IORef NameCache -> VarEnv Bool -> TidyOccEnv + -> Id -> IO (TidyOccEnv, Name) +tidyTopName mod nc_var ext_ids occ_env id + | global && internal = return (occ_env, localiseName name) + + | global && external = return (occ_env, name) + -- Global names are assumed to have been allocated by the renamer, + -- so they already have the "right" unique + -- And it's a system-wide unique too + + -- Now we get to the real reason that all this is in the IO Monad: + -- we have to update the name cache in a nice atomic fashion + + | local && internal = do { nc <- readIORef nc_var + ; let (nc', new_local_name) = mk_new_local nc + ; writeIORef nc_var nc' + ; return (occ_env', new_local_name) } + -- Even local, internal names must get a unique occurrence, because + -- if we do -split-objs we externalise the name later, in the code generator + -- + -- Similarly, we must make sure it has a system-wide Unique, because + -- the byte-code generator builds a system-wide Name->BCO symbol table + + | local && external = do { nc <- readIORef nc_var + ; let (nc', new_external_name) = mk_new_external nc + ; writeIORef nc_var nc' + ; return (occ_env', new_external_name) } + where + name = idName id + external = id `elemVarEnv` ext_ids + global = isExternalName name + local = not global + internal = not external + mb_parent = nameParent_maybe name + loc = nameSrcLoc name + + (occ_env', occ') = tidyOccName occ_env (nameOccName name) + + mk_new_local nc = (nc { nsUniqs = us2 }, mkInternalName uniq occ' loc) + where + (us1, us2) = splitUniqSupply (nsUniqs nc) + uniq = uniqFromSupply us1 + + mk_new_external nc = allocateGlobalBinder nc mod occ' mb_parent loc + -- If we want to externalise a currently-local name, check + -- whether we have already assigned a unique for it. + -- If so, use it; if not, extend the table. + -- All this is done by allcoateGlobalBinder. + -- This is needed when *re*-compiling a module in GHCi; we want to + -- use the same name for externally-visible things as we did before. + + +----------------------------------------------------------- +tidyTopPair :: VarEnv Bool + -> TidyEnv -- The TidyEnv is used to tidy the IdInfo + -- It is knot-tied: don't look at it! + -> CafInfo + -> Name -- New name + -> (Id, CoreExpr) -- Binder and RHS before tidying + -> (Id, CoreExpr) -- This function is the heart of Step 2 -- The rec_tidy_env is the one to use for the IdInfo -- It's necessary because when we are dealing with a recursive -- group, a variable late in the group might be mentioned -- in the IdInfo of one early in the group - -- The rhs is already tidied - - = ASSERT(isLocalId id) -- "all Ids defined in this module are local - -- until the CoreTidy phase" --GHC comentary - ((orig_env', occ_env', subst_env'), id') +tidyTopPair ext_ids rhs_tidy_env caf_info name' (bndr, rhs) + = ASSERT(isLocalId bndr) -- "all Ids defined in this module are local + -- until the CoreTidy phase" --GHC comentary + (bndr', rhs') where - (orig_env', occ_env', name') = tidyTopName mod ns2 occ_env2 - is_external - (idName id) - ty' = tidyTopType (idType id) - idinfo = tidyTopIdInfo rec_tidy_env is_external - (idInfo id) unfold_info arity - caf_info - - id' = mkVanillaGlobal name' ty' idinfo - - subst_env' = extendVarEnv subst_env2 id id' - - maybe_external = lookupVarEnv ext_ids id - is_external = isJust maybe_external + bndr' = mkVanillaGlobal name' ty' idinfo' + ty' = tidyTopType (idType bndr) + rhs' = tidyExpr rhs_tidy_env rhs + idinfo' = tidyTopIdInfo rhs_tidy_env (isJust maybe_external) + (idInfo bndr) unfold_info arity + caf_info -- Expose an unfolding if ext_ids tells us to -- Remember that ext_ids maps an Id to a Bool: -- True to show the unfolding, False to hide it + maybe_external = lookupVarEnv ext_ids bndr show_unfold = maybe_external `orElse` False - unfold_info | show_unfold = mkTopUnfolding tidy_rhs + unfold_info | show_unfold = mkTopUnfolding rhs' | otherwise = noUnfolding -- Usually the Id will have an accurate arity on it, because @@ -542,50 +595,6 @@ tidyTopIdInfo tidy_env is_external idinfo unfold_info arity caf_info -- They have already been extracted by findExternalRules --- This is where we set names to local/global based on whether they really are --- externally visible (see comment at the top of this module). If the name --- was previously local, we have to give it a unique occurrence name if --- we intend to externalise it. -tidyTopName mod ns occ_env external name - | global && internal = (ns, occ_env, localiseName name) - - | global && external = (ns, occ_env, name) - -- Global names are assumed to have been allocated by the renamer, - -- so they already have the "right" unique - -- And it's a system-wide unique too - - | local && internal = (ns_w_local, occ_env', new_local_name) - -- Even local, internal names must get a unique occurrence, because - -- if we do -split-objs we externalise the name later, in the code generator - -- - -- Similarly, we must make sure it has a system-wide Unique, because - -- the byte-code generator builds a system-wide Name->BCO symbol table - - | local && external = case lookupOrigNameCache ns_names mod occ' of - Just orig -> (ns, occ_env', orig) - Nothing -> (ns_w_global, occ_env', new_external_name) - -- If we want to externalise a currently-local name, check - -- whether we have already assigned a unique for it. - -- If so, use it; if not, extend the table (ns_w_global). - -- This is needed when *re*-compiling a module in GHCi; we want to - -- use the same name for externally-visible things as we did before. - - where - global = isExternalName name - local = not global - internal = not external - loc = nameSrcLoc name - - (occ_env', occ') = tidyOccName occ_env (nameOccName name) - - ns_names = nsNames ns - (us1, us2) = splitUniqSupply (nsUniqs ns) - uniq = uniqFromSupply us1 - new_local_name = mkInternalName uniq occ' loc - ns_w_local = ns { nsUniqs = us2 } - - (ns_w_global, new_external_name) = newExternalName ns mod occ' loc - ------------ Worker -------------- tidyWorker tidy_env (HasWorker work_id wrap_arity) diff --git a/ghc/compiler/nativeGen/MachMisc.lhs b/ghc/compiler/nativeGen/MachMisc.lhs index e58821036a..63379cba32 100644 --- a/ghc/compiler/nativeGen/MachMisc.lhs +++ b/ghc/compiler/nativeGen/MachMisc.lhs @@ -65,7 +65,7 @@ import FastString import GLAEXTS import TRACE ( trace ) -import Maybe ( catMaybes ) +import Maybes ( mapCatMaybes ) \end{code} \begin{code} @@ -116,7 +116,7 @@ save_cands = [BaseReg,Sp,SpLim,Hp,HpLim] restore_cands = save_cands volatileSavesOrRestores do_saves vols - = catMaybes (map mkCode vols) + = mapCatMaybes mkCode vols where mkCode mid | case mid of { BaseReg -> True; _ -> False } diff --git a/ghc/compiler/nativeGen/StixMacro.lhs b/ghc/compiler/nativeGen/StixMacro.lhs index 8c3dafbbe8..be32d651a1 100644 --- a/ghc/compiler/nativeGen/StixMacro.lhs +++ b/ghc/compiler/nativeGen/StixMacro.lhs @@ -12,7 +12,6 @@ import {-# SOURCE #-} StixPrim ( amodeToStix ) import MachRegs import AbsCSyn ( CStmtMacro(..), CAddrMode, tagreg, CCheckMacro(..) ) -import SMRep ( fixedHdrSize ) import Constants ( uF_RET, uF_UPDATEE, uF_SIZE ) import ForeignCall ( CCallConv(..) ) import MachOp ( MachOp(..) ) @@ -21,7 +20,6 @@ import Stix import Panic ( panic ) import UniqSupply ( returnUs, thenUs, UniqSM ) import CLabel ( mkBlackHoleInfoTableLabel, mkIndStaticInfoLabel, - mkBlackHoleBQInfoTableLabel, mkIndInfoLabel, mkUpdInfoLabel, mkRtsGCEntryLabel ) \end{code} -------------------------------------------------------------------------------- @@ -145,12 +143,10 @@ Let's make sure that these CAFs are lifted out, shall we? \begin{code} -- Some common labels -bh_info, ind_static_info, ind_info :: StixExpr +bh_info, ind_static_info :: StixExpr bh_info = StCLbl mkBlackHoleInfoTableLabel -bq_info = StCLbl mkBlackHoleBQInfoTableLabel ind_static_info = StCLbl mkIndStaticInfoLabel -ind_info = StCLbl mkIndInfoLabel upd_frame_info = StCLbl mkUpdInfoLabel -- Some common call trees diff --git a/ghc/compiler/nativeGen/StixPrim.lhs b/ghc/compiler/nativeGen/StixPrim.lhs index d1edcc022c..ed6d9da074 100644 --- a/ghc/compiler/nativeGen/StixPrim.lhs +++ b/ghc/compiler/nativeGen/StixPrim.lhs @@ -19,10 +19,9 @@ import Literal ( Literal(..), word2IntLit ) import MachOp ( MachOp(..) ) import PrimRep ( PrimRep(..), getPrimRepSizeInBytes ) import UniqSupply ( returnUs, thenUs, getUniqueUs, UniqSM ) -import Constants ( mIN_INTLIKE, mIN_CHARLIKE, uF_UPDATEE, bLOCK_SIZE, +import Constants ( mIN_INTLIKE, mIN_CHARLIKE, bLOCK_SIZE, rESERVED_STACK_WORDS ) import CLabel ( mkIntlikeClosureLabel, mkCharlikeClosureLabel, - mkMAP_FROZEN_infoLabel, mkForeignLabel ) import ForeignCall ( ForeignCall(..), CCallSpec(..), CCallTarget(..), CCallConv(..), playSafe, playThreadSafe ) @@ -230,8 +229,6 @@ iNTLIKE_closure = StCLbl mkIntlikeClosureLabel cHARLIKE_closure :: StixExpr cHARLIKE_closure = StCLbl mkCharlikeClosureLabel -mutArrPtrsFrozen_info = StCLbl mkMAP_FROZEN_infoLabel - -- these are the sizes of charLike and intLike closures, in _bytes_. charLikeSize = (fixedHdrSize + 1) * (getPrimRepSizeInBytes PtrRep) intLikeSize = (fixedHdrSize + 1) * (getPrimRepSizeInBytes PtrRep) diff --git a/ghc/compiler/ndpFlatten/FlattenMonad.hs b/ghc/compiler/ndpFlatten/FlattenMonad.hs index b8a2114ac0..4bca818dd3 100644 --- a/ghc/compiler/ndpFlatten/FlattenMonad.hs +++ b/ghc/compiler/ndpFlatten/FlattenMonad.hs @@ -74,18 +74,16 @@ import Name (Name) import VarSet (VarSet, emptyVarSet, extendVarSet, varSetElems ) import VarEnv (VarEnv, emptyVarEnv, zipVarEnv, plusVarEnv, elemVarEnv, lookupVarEnv, lookupVarEnv_NF, delVarEnvList) -import TyCon (tyConName) import Type (Type, tyConAppTyCon) -import HscTypes (HomePackageTable, PersistentCompilerState(pcs_EPS), +import HscTypes (HomePackageTable, ExternalPackageState(eps_PTE), HscEnv(hsc_HPT), TyThing(..), lookupType) -import PrelNames (charPrimTyConName, intPrimTyConName, floatPrimTyConName, - doublePrimTyConName, fstName, andName, orName, +import PrelNames ( fstName, andName, orName, lengthPName, replicatePName, mapPName, bpermutePName, bpermuteDftPName, indexOfPName) -import PrimOp (eqCharName, eqIntName, eqFloatName, eqDoubleName, - neqIntName) - -- neqCharName, neqFloatName,neqDoubleName, +import TysPrim ( charPrimTyCon, intPrimTyCon, floatPrimTyCon, doublePrimTyCon ) +import PrimOp ( PrimOp(..) ) +import PrelInfo ( primOpId ) import CoreSyn (Expr(..), Bind(..), CoreBndr, CoreExpr, CoreBind, mkApps) import CoreUtils (exprType) @@ -130,11 +128,11 @@ data FlattenState = FlattenState { -- initial value of the flattening state -- -initialFlattenState :: PersistentCompilerState +initialFlattenState :: ExternalPackageState -> HomePackageTable -> UniqSupply -> FlattenState -initialFlattenState pcs hpt us = +initialFlattenState eps hpt us = FlattenState { us = us, env = lookup, @@ -144,7 +142,7 @@ initialFlattenState pcs hpt us = } where lookup n = - case lookupType hpt (eps_PTE (pcs_EPS pcs)) n of + case lookupType hpt (eps_PTE eps) n of Just (AnId v) -> v _ -> pprPanic "FlattenMonad: unknown name:" (ppr n) @@ -164,12 +162,12 @@ instance Monad Flatten where -- execute the given flattening computation (EXPORTED) -- runFlatten :: HscEnv - -> PersistentCompilerState + -> ExternalPackageState -> UniqSupply -> Flatten a -> a -runFlatten hsc_env pcs us m - = fst $ unFlatten m (initialFlattenState pcs (hsc_HPT hsc_env) us) +runFlatten hsc_env eps us m + = fst $ unFlatten m (initialFlattenState eps (hsc_HPT hsc_env) us) -- variable generation @@ -364,14 +362,14 @@ mk'or a1 a2 = mkFunApp orName [a1, a2] -- `Double') (EXPORTED) -- mk'eq :: Type -> CoreExpr -> CoreExpr -> Flatten CoreExpr -mk'eq ty a1 a2 = mkFunApp eqName [a1, a2] +mk'eq ty a1 a2 = return (mkApps (Var eqName) [a1, a2]) where - name = tyConName . tyConAppTyCon $ ty + tc = tyConAppTyCon ty -- - eqName | name == charPrimTyConName = eqCharName - | name == intPrimTyConName = eqIntName - | name == floatPrimTyConName = eqFloatName - | name == doublePrimTyConName = eqDoubleName + eqName | tc == charPrimTyCon = primOpId CharEqOp + | tc == intPrimTyCon = primOpId IntEqOp + | tc == floatPrimTyCon = primOpId FloatEqOp + | tc == doublePrimTyCon = primOpId DoubleEqOp | otherwise = pprPanic "FlattenMonad.mk'eq: " (ppr ty) @@ -380,12 +378,12 @@ mk'eq ty a1 a2 = mkFunApp eqName [a1, a2] -- `Double') (EXPORTED) -- mk'neq :: Type -> CoreExpr -> CoreExpr -> Flatten CoreExpr -mk'neq ty a1 a2 = mkFunApp neqName [a1, a2] +mk'neq ty a1 a2 = return (mkApps (Var neqName) [a1, a2]) where - name = tyConName . tyConAppTyCon $ ty + tc = tyConAppTyCon ty -- neqName {- | name == charPrimTyConName = neqCharName -} - | name == intPrimTyConName = neqIntName + | tc == intPrimTyCon = primOpId IntNeOp {- | name == floatPrimTyConName = neqFloatName -} {- | name == doublePrimTyConName = neqDoubleName -} | otherwise = diff --git a/ghc/compiler/ndpFlatten/Flattening.hs b/ghc/compiler/ndpFlatten/Flattening.hs index 4f0f86b53a..14b68d190d 100644 --- a/ghc/compiler/ndpFlatten/Flattening.hs +++ b/ghc/compiler/ndpFlatten/Flattening.hs @@ -73,8 +73,7 @@ import Var (Var(..)) import DataCon (DataCon, dataConTag) import TypeRep (Type(..)) import Type (isTypeKind) -import HscTypes (PersistentCompilerState, ModGuts(..), - ModGuts, HscEnv(..) ) +import HscTypes ( ModGuts(..), ModGuts, HscEnv(..), hscEPS ) import CoreFVs (exprFreeVars) import CoreSyn (Expr(..), Bind(..), Alt(..), AltCon(..), Note(..), CoreBndr, CoreExpr, CoreBind, mkLams, mkLets, @@ -103,15 +102,15 @@ import Monad (liftM, foldM) -- compiling a complete module (EXPORTED) -- flatten :: HscEnv - -> PersistentCompilerState -> ModGuts -> IO ModGuts -flatten hsc_env pcs mod_impl@(ModGuts {mg_binds = binds}) +flatten hsc_env mod_impl@(ModGuts {mg_binds = binds}) | not opt_Flatten = return mod_impl -- skip without -fflatten | otherwise = do let dflags = hsc_dflags hsc_env + eps <- hscEPS hsc_env us <- mkSplitUniqSupply 'l' -- 'l' as in fLattening -- -- announce vectorisation @@ -120,7 +119,7 @@ flatten hsc_env pcs mod_impl@(ModGuts {mg_binds = binds}) -- -- vectorise all toplevel bindings -- - let binds' = runFlatten hsc_env pcs us $ vectoriseTopLevelBinds binds + let binds' = runFlatten hsc_env eps us $ vectoriseTopLevelBinds binds -- -- and dump the result if requested -- @@ -132,14 +131,14 @@ flatten hsc_env pcs mod_impl@(ModGuts {mg_binds = binds}) -- compiling a single expression in interactive mode (EXPORTED) -- flattenExpr :: HscEnv - -> PersistentCompilerState -> CoreExpr -- the expression to be flattened -> IO CoreExpr -flattenExpr hsc_env pcs expr +flattenExpr hsc_env expr | not opt_Flatten = return expr -- skip without -fflatten | otherwise = do let dflags = hsc_dflags hsc_env + eps <- hscEPS hsc_env us <- mkSplitUniqSupply 'l' -- 'l' as in fLattening -- @@ -149,7 +148,7 @@ flattenExpr hsc_env pcs expr -- -- vectorise the expression -- - let expr' = fst . runFlatten hsc_env pcs us $ vectorise expr + let expr' = fst . runFlatten hsc_env eps us $ vectorise expr -- -- and dump the result if requested -- diff --git a/ghc/compiler/ndpFlatten/NDPCoreUtils.hs b/ghc/compiler/ndpFlatten/NDPCoreUtils.hs index 1d221baae1..1bf74b4866 100644 --- a/ghc/compiler/ndpFlatten/NDPCoreUtils.hs +++ b/ghc/compiler/ndpFlatten/NDPCoreUtils.hs @@ -51,14 +51,13 @@ module NDPCoreUtils ( import Panic (panic) import Outputable (Outputable(ppr), pprPanic) import BasicTypes (Boxity(..)) -import Var (Var) import Type (Type, splitTyConApp_maybe, splitFunTy) -import TyCon (TyCon(..), isTupleTyCon) -import PrelNames (parrTyConName) +import TyCon (isTupleTyCon) import TysWiredIn (parrTyCon, unitDataConId, tupleCon, intDataCon, mkPArrTy, boolTy) -import CoreSyn (CoreBndr, CoreExpr, CoreBind, CoreAlt, Expr(..), AltCon(..), +import CoreSyn (CoreExpr, CoreAlt, Expr(..), AltCon(..), Bind(..), mkConApp) +import PprCore ( {- instances -} ) import Var (Id) import VarEnv (IdEnv, delVarEnv, delVarEnvList, lookupVarEnv) @@ -90,7 +89,7 @@ funTyArgs = splitFunTy parrElemTy :: Type -> Type parrElemTy ty = case splitTyConApp_maybe ty of - Just (tyCon, [argTy]) | tyConName tyCon == parrTyConName -> argTy + Just (tyCon, [argTy]) | tyCon == parrTyCon -> argTy _ -> pprPanic "NDPCoreUtils.parrElemTy: wrong type: " (ppr ty) diff --git a/ghc/compiler/ndpFlatten/PArrAnal.hs b/ghc/compiler/ndpFlatten/PArrAnal.hs index 0c25805d2c..46643d1a05 100644 --- a/ghc/compiler/ndpFlatten/PArrAnal.hs +++ b/ghc/compiler/ndpFlatten/PArrAnal.hs @@ -42,6 +42,7 @@ import TypeRep (Type(..)) import Var (Var(..),Id) import Literal (Literal) import CoreSyn (Expr(..),CoreExpr,Bind(..)) +import PprCore ( {- instances -} ) -- data ArrayUsage = Prim | NonPrim | Array @@ -135,8 +136,8 @@ typeArrayUsage (TyConApp tc tcargs) = tcargsAU = map typeArrayUsage tcargs tcCombine = foldr combineArrayUsage Prim tcargsAU in auCon tcCombine -typeArrayUsage t@(SourceTy _) = - pprPanic "PArrAnal.typeArrayUsage: encountered 'SourceType - shouldn't be here!" +typeArrayUsage t@(PredTy _) = + pprPanic "PArrAnal.typeArrayUsage: encountered 'PredType - shouldn't be here!" (ppr t) diff --git a/ghc/compiler/parser/Lexer.x b/ghc/compiler/parser/Lexer.x index 997a7d7d88..52fc03e7c0 100644 --- a/ghc/compiler/parser/Lexer.x +++ b/ghc/compiler/parser/Lexer.x @@ -1084,8 +1084,7 @@ data ParseResult a -- show this span, e.g. by highlighting it. Message -- The error message -showPFailed loc1 loc2 err - = showSDoc (hcat [ppr loc1, text ": ", err]) +showPFailed loc1 loc2 err = hcat [ppr loc1, text ": ", err] data PState = PState { buffer :: StringBuffer, diff --git a/ghc/compiler/parser/Parser.y b/ghc/compiler/parser/Parser.y index 7976b1b25f..925be4e7e1 100644 --- a/ghc/compiler/parser/Parser.y +++ b/ghc/compiler/parser/Parser.y @@ -1,6 +1,6 @@ {- -*-haskell-*- ----------------------------------------------------------------------------- -$Id: Parser.y,v 1.125 2003/09/24 13:04:51 simonmar Exp $ +$Id: Parser.y,v 1.126 2003/10/09 11:59:02 simonpj Exp $ Haskell grammar. @@ -14,29 +14,24 @@ module Parser ( parseModule, parseStmt, parseIdentifier, parseIface ) where #include "HsVersions.h" import HsSyn -import HsTypes ( mkHsTupCon ) - import RdrHsSyn -import HscTypes ( ParsedIface(..), IsBootInterface, noDependencies ) +import HscTypes ( ModIface, IsBootInterface, DeprecTxt ) import Lexer import RdrName -import PrelNames ( mAIN_Name, funTyConName, listTyConName, - parrTyConName, consDataConName ) -import TysWiredIn ( unitTyCon, unitDataCon, tupleTyCon, - tupleCon, nilDataCon ) +import TysWiredIn ( unitTyCon, unitDataCon, tupleTyCon, tupleCon, nilDataCon, + listTyCon_RDR, parrTyCon_RDR, consDataCon_RDR ) +import Type ( funTyCon ) import ForeignCall ( Safety(..), CExportSpec(..), - CCallConv(..), CCallTarget(..), defaultCCallConv, + CCallConv(..), CCallTarget(..), defaultCCallConv ) -import OccName ( UserFS, varName, tcName, dataName, tcClsName, tvName ) -import TyCon ( DataConDetails(..) ) +import OccName ( UserFS, varName, dataName, tcClsName, tvName ) import DataCon ( DataCon, dataConName ) -import SrcLoc ( SrcLoc ) +import SrcLoc ( SrcLoc, noSrcLoc ) import Module -import CmdLineOpts ( opt_SccProfilingOn, opt_InPackage ) +import CmdLineOpts ( opt_SccProfilingOn ) import Type ( Kind, mkArrowKind, liftedTypeKind ) -import BasicTypes ( Boxity(..), Fixity(..), FixityDirection(..), - IPName(..), NewOrData(..), StrictnessMark(..), - Activation(..), FixitySig(..) ) +import BasicTypes ( Boxity(..), Fixity(..), FixityDirection(..), IPName(..), + NewOrData(..), Activation(..) ) import Panic import GLAEXTS @@ -266,37 +261,32 @@ cvtopdecls :: { [RdrNameHsDecl] } ----------------------------------------------------------------------------- -- Interfaces (.hi-boot files) -iface :: { ParsedIface } - : 'module' modid 'where' ifacebody - { ParsedIface { - pi_mod = $2, - pi_pkg = opt_InPackage, - pi_vers = 1, -- Module version - pi_orphan = False, - pi_exports = (1,[($2,mkIfaceExports $4)]), - pi_deps = noDependencies, - pi_usages = [], - pi_fixity = [], - pi_insts = [], - pi_decls = map (\x -> (1,x)) $4, - pi_rules = (1,[]), - pi_deprecs = Nothing - } - } - -ifacebody :: { [RdrNameTyClDecl] } +iface :: { ModIface } + : 'module' modid 'where' ifacebody { mkBootIface $2 $4 } + +ifacebody :: { [HsDecl RdrName] } : '{' ifacedecls '}' { $2 } | vocurly ifacedecls close { $2 } -ifacedecls :: { [RdrNameTyClDecl] } +ifacedecls :: { [HsDecl RdrName] } : ifacedecl ';' ifacedecls { $1 : $3 } | ';' ifacedecls { $2 } | ifacedecl { [$1] } | {- empty -} { [] } -ifacedecl :: { RdrNameTyClDecl } - : tycl_decl { $1 } - | srcloc var '::' sigtype { IfaceSig $2 $4 [] $1 } +ifacedecl :: { HsDecl RdrName } + : var '::' sigtype + { SigD (Sig $1 $3 noSrcLoc) } + | 'type' syn_hdr '=' ctype + { let (tc,tvs) = $2 in TyClD (TySynonym tc tvs $4 noSrcLoc) } + | new_or_data tycl_hdr + { TyClD (mkTyData $1 $2 [] Nothing noSrcLoc) } + | 'class' tycl_hdr fds + { TyClD (mkClassDecl $2 $3 [] EmptyMonoBinds noSrcLoc) } + +new_or_data :: { NewOrData } + : 'data' { DataType } + | 'newtype' { NewType } ----------------------------------------------------------------------------- -- The Export List @@ -393,7 +383,7 @@ topdecl :: { RdrBinding } : tycl_decl { RdrHsDecl (TyClD $1) } | srcloc 'instance' inst_type where { let (binds,sigs) = cvMonoBindsAndSigs $4 - in RdrHsDecl (InstD (InstDecl $3 binds sigs Nothing $1)) } + in RdrHsDecl (InstD (InstDecl $3 binds sigs $1)) } | srcloc 'default' '(' comma_types0 ')' { RdrHsDecl (DefD (DefaultDecl $4 $1)) } | 'foreign' fdecl { RdrHsDecl $2 } | '{-# DEPRECATED' deprecations '#-}' { RdrBindings (reverse $2) } @@ -409,18 +399,17 @@ tycl_decl :: { RdrNameTyClDecl } -- Instead we just say b is out of scope { let (tc,tvs) = $3 in TySynonym tc tvs $5 $1 } - | srcloc 'data' tycl_hdr constrs deriving - { mkTyData DataType $3 (DataCons (reverse $4)) $5 $1 } + { mkTyData DataType $3 (reverse $4) $5 $1 } | srcloc 'newtype' tycl_hdr '=' newconstr deriving - { mkTyData NewType $3 (DataCons [$5]) $6 $1 } + { mkTyData NewType $3 [$5] $6 $1 } | srcloc 'class' tycl_hdr fds where { let (binds,sigs) = cvMonoBindsAndSigs $5 in - mkClassDecl $3 $4 sigs (Just binds) $1 } + mkClassDecl $3 $4 sigs binds $1 } syn_hdr :: { (RdrName, [RdrNameHsTyVar]) } -- We don't retain the syntax of an infix -- type synonym declaration. Oh well. @@ -434,10 +423,8 @@ syn_hdr :: { (RdrName, [RdrNameHsTyVar]) } -- We don't retain the syntax of an i -- (Eq a, Ord b) => T a b -- Rather a lot of inlining here, else we get reduce/reduce errors tycl_hdr :: { (RdrNameContext, RdrName, [RdrNameHsTyVar]) } - : context '=>' type {% checkTyClHdr $3 >>= \ (tc,tvs) -> - return ($1, tc, tvs) } - | type {% checkTyClHdr $1 >>= \ (tc,tvs) -> - return ([], tc, tvs) } + : context '=>' type {% checkTyClHdr $1 $3 } + | type {% checkTyClHdr [] $1 } ----------------------------------------------------------------------------- -- Nested declarations @@ -715,9 +702,9 @@ type :: { RdrNameHsType } gentype :: { RdrNameHsType } : btype { $1 } - | btype qtyconop gentype { HsOpTy $1 (HsTyOp $2) $3 } - | btype '`' tyvar '`' gentype { HsOpTy $1 (HsTyOp $3) $5 } - | btype '->' gentype { HsOpTy $1 HsArrow $3 } + | btype qtyconop gentype { HsOpTy $1 $2 $3 } + | btype '`' tyvar '`' gentype { HsOpTy $1 $3 $5 } + | btype '->' gentype { HsFunTy $1 $3 } btype :: { RdrNameHsType } : btype atype { HsAppTy $1 $2 } @@ -726,8 +713,8 @@ btype :: { RdrNameHsType } atype :: { RdrNameHsType } : gtycon { HsTyVar $1 } | tyvar { HsTyVar $1 } - | '(' type ',' comma_types1 ')' { HsTupleTy (mkHsTupCon tcName Boxed ($2:$4)) ($2:$4) } - | '(#' comma_types1 '#)' { HsTupleTy (mkHsTupCon tcName Unboxed $2) $2 } + | '(' type ',' comma_types1 ')' { HsTupleTy Boxed ($2:$4) } + | '(#' comma_types1 '#)' { HsTupleTy Unboxed $2 } | '[' type ']' { HsListTy $2 } | '[:' type ':]' { HsPArrTy $2 } | '(' ctype ')' { HsParTy $2 } @@ -756,7 +743,7 @@ tv_bndrs :: { [RdrNameHsTyVar] } tv_bndr :: { RdrNameHsTyVar } : tyvar { UserTyVar $1 } - | '(' tyvar '::' kind ')' { IfaceTyVar $2 $4 } + | '(' tyvar '::' kind ')' { KindedTyVar $2 $4 } fds :: { [([RdrName], [RdrName])] } : {- empty -} { [] } @@ -838,9 +825,9 @@ stype :: { RdrNameBangType } : ctype { unbangedType $1 } | strict_mark atype { BangType $1 $2 } -strict_mark :: { StrictnessMark } - : '!' { MarkedUserStrict } - | '!' '!' { MarkedUserUnboxed } +strict_mark :: { HsBang } + : '!' { HsStrict } + | '!' '!' { HsUnbox } deriving :: { Maybe RdrNameContext } : {- empty -} { Nothing } @@ -984,6 +971,8 @@ aexp1 :: { RdrNameHsExpr } -- Here was the syntax for type applications that I was planning -- but there are difficulties (e.g. what order for type args) -- so it's not enabled yet. +-- But this case *is* used for the left hand side of a generic definition, +-- which is parsed as an expression before being munged into a pattern | qcname '{|' gentype '|}' { (HsApp (HsVar $1) (HsType $3)) } aexp2 :: { RdrNameHsExpr } @@ -1267,9 +1256,9 @@ gtycon :: { RdrName } -- A "general" qualified tycon : oqtycon { $1 } | '(' ')' { getRdrName unitTyCon } | '(' commas ')' { getRdrName (tupleTyCon Boxed $2) } - | '(' '->' ')' { nameRdrName funTyConName } - | '[' ']' { nameRdrName listTyConName } - | '[:' ':]' { nameRdrName parrTyConName } + | '(' '->' ')' { getRdrName funTyCon } + | '[' ']' { listTyCon_RDR } + | '[:' ':]' { parrTyCon_RDR } oqtycon :: { RdrName } -- An "ordinary" qualified tycon : qtycon { $1 } @@ -1398,8 +1387,7 @@ consym :: { RdrName } : CONSYM { mkUnqual dataName $1 } -- ':' means only list cons - | ':' { nameRdrName consDataConName } - -- NB: SrcName because we are reading source + | ':' { consDataCon_RDR } ----------------------------------------------------------------------------- diff --git a/ghc/compiler/parser/ParserCore.y b/ghc/compiler/parser/ParserCore.y index dd438b1413..4f025f9c0f 100644 --- a/ghc/compiler/parser/ParserCore.y +++ b/ghc/compiler/parser/ParserCore.y @@ -1,23 +1,23 @@ { module ParserCore ( parseCore ) where +import IfaceSyn import ForeignCall - -import HsCore import RdrHsSyn +import TcIface ( tcIfaceKind ) import HsSyn -import TyCon -import TcType import RdrName import OccName +import Name( nameOccName, nameModuleName ) import Module import ParserCoreUtils import LexCore import Literal import BasicTypes -import Type import SrcLoc -import PrelNames +import TysPrim( wordPrimTyCon, intPrimTyCon, charPrimTyCon, + floatPrimTyCon, doublePrimTyCon, addrPrimTyCon ) +import TyCon ( TyCon, tyConName ) import FastString import Outputable @@ -68,154 +68,182 @@ import Outputable %% -module :: { RdrNameHsModule } - : '%module' modid tdefs vdefgs - { HsModule (Just (mkHomeModule $2)) Nothing - [] ($3 ++ concat $4) Nothing noSrcLoc} +module :: { HsExtCore RdrName } + : '%module' modid tdefs vdefgs + { HsExtCore (mkHomeModule $2) $3 $4 } + +modid :: { ModuleName } + : CNAME { mkSysModuleNameFS (mkFastString $1) } + +------------------------------------------------------------- +-- Type and newtype declarations are in HsSyn syntax -tdefs :: { [RdrNameHsDecl] } +tdefs :: { [TyClDecl RdrName] } : {- empty -} {[]} | tdef ';' tdefs {$1:$3} -tdef :: { RdrNameHsDecl } - : '%data' q_tc_name tbinds '=' '{' cons1 '}' - { TyClD (mkTyData DataType ([], $2, $3) (DataCons $6) Nothing noSrcLoc) } - | '%newtype' q_tc_name tbinds trep - { TyClD (mkTyData NewType ([], $2, $3) ($4 $2) Nothing noSrcLoc) } +tdef :: { TyClDecl RdrName } + : '%data' q_tc_name tv_bndrs '=' '{' cons1 '}' + { mkTyData DataType ([], ifaceExtRdrName $2, map toHsTvBndr $3) $6 Nothing noSrcLoc } + | '%newtype' q_tc_name tv_bndrs trep + { let tc_rdr = ifaceExtRdrName $2 in + mkTyData NewType ([], tc_rdr, map toHsTvBndr $3) ($4 (rdrNameOcc tc_rdr)) Nothing noSrcLoc } -- For a newtype we have to invent a fake data constructor name -- It doesn't matter what it is, because it won't be used -trep :: { (RdrName -> DataConDetails (ConDecl RdrName)) } - : {- empty -} { (\ tc_name -> Unknown) } - | '=' ty { (\ tc_name -> let { dc_name = setRdrNameSpace tc_name dataName ; - con_info = PrefixCon [unbangedType $2] } - in DataCons [ConDecl dc_name [] [] con_info noSrcLoc]) } +trep :: { OccName -> [ConDecl RdrName] } + : {- empty -} { (\ tc_occ -> []) } + | '=' ty { (\ tc_occ -> let { dc_name = mkRdrUnqual (setOccNameSpace dataName tc_occ) ; + con_info = PrefixCon [unbangedType (toHsType $2)] } + in [ConDecl dc_name [] [] con_info noSrcLoc]) } -tbind :: { HsTyVarBndr RdrName } - : name { IfaceTyVar $1 liftedTypeKind } - | '(' name '::' akind ')' { IfaceTyVar $2 $4 } +cons1 :: { [ConDecl RdrName] } + : con { [$1] } + | con ';' cons1 { $1:$3 } -tbinds :: { [HsTyVarBndr RdrName] } - : {- empty -} { [] } - | tbind tbinds { $1:$2 } +con :: { ConDecl RdrName } + : d_pat_occ attv_bndrs hs_atys + { ConDecl (mkRdrUnqual $1) $2 [] (PrefixCon (map unbangedType $3)) noSrcLoc} -vdefgs :: { [[RdrNameHsDecl]] } - : {- empty -} { [] } - | vdefg ';' vdefgs { ($1:$3) } +attv_bndrs :: { [HsTyVarBndr RdrName] } + : {- empty -} { [] } + | '@' tv_bndr attv_bndrs { toHsTvBndr $2 : $3 } -vdefg :: { [RdrNameHsDecl] } - : '%rec' '{' vdefs1 '}' { map CoreD $3 } - | vdef { [CoreD $1] } +hs_atys :: { [HsType RdrName] } + : atys { map toHsType $1 } -let_bind :: { UfBinding RdrName } - : '%rec' '{' vdefs1 '}' { UfRec (map convBind $3) } - | vdef { let (b,r) = convBind $1 - in UfNonRec b r } -vdefs1 :: { [RdrNameCoreDecl] } - : vdef { [$1] } - | vdef ';' vdefs1 { $1:$3 } +--------------------------------------- +-- Types +--------------------------------------- -vdef :: { RdrNameCoreDecl } - : qname '::' ty '=' exp { CoreDecl $1 $3 $5 noSrcLoc } - -- NB: qname includes data constructors, because - -- we allow data-constructor wrappers at top level +atys :: { [IfaceType] } + : {- empty -} { [] } + | aty atys { $1:$2 } +aty :: { IfaceType } + : tv_occ { IfaceTyVar $1 } + | q_tc_name { IfaceTyConApp (IfaceTc $1) [] } + | '(' ty ')' { $2 } -vbind :: { (RdrName, RdrNameHsType) } - : '(' name '::' ty ')' { ($2,$4) } +bty :: { IfaceType } + : tv_occ atys { foldl IfaceAppTy (IfaceTyVar $1) $2 } + | q_tc_name atys { IfaceTyConApp (IfaceTc $1) $2 } -vbinds :: { [(RdrName, RdrNameHsType)] } - : {-empty -} { [] } - | vbind vbinds { $1:$2 } +ty :: { IfaceType } + : bty { $1 } + | bty '->' ty { IfaceFunTy $1 $3 } + | '%forall' tv_bndrs '.' ty { foldr IfaceForAllTy $4 $2 } -bind :: { UfBinder RdrName } - : '@' tbind { let (IfaceTyVar v k) = $2 in UfTyBinder v k } - | vbind { let (v,ty) = $1 in UfValBinder v ty } +---------------------------------------------- +-- Bindings are in Iface syntax -binds1 :: { [UfBinder RdrName] } - : bind { [$1] } - | bind binds1 { $1:$2 } +vdefgs :: { [IfaceBinding] } + : {- empty -} { [] } + | let_bind ';' vdefgs { $1 : $3 } -attbinds :: { [RdrNameHsTyVar] } - : {- empty -} { [] } - | '@' tbind attbinds { $2:$3 } +let_bind :: { IfaceBinding } + : '%rec' '{' vdefs1 '}' { IfaceRec $3 } + | vdef { let (b,r) = $1 + in IfaceNonRec b r } -akind :: { Kind } - : '*' { liftedTypeKind } - | '#' { unliftedTypeKind } - | '?' { openTypeKind } - | '(' kind ')' { $2 } +vdefs1 :: { [(IfaceIdBndr, IfaceExpr)] } + : vdef { [$1] } + | vdef ';' vdefs1 { $1:$3 } -kind :: { Kind } - : akind { $1 } - | akind '->' kind { mkArrowKind $1 $3 } +vdef :: { (IfaceIdBndr, IfaceExpr) } + : qd_occ '::' ty '=' exp { (($1, $3), $5) } + -- NB: qd_occ includes data constructors, because + -- we allow data-constructor wrappers at top level + -- But we discard the module name, because it must be the + -- same as the module being compiled, and Iface syntax only + -- has OccNames in binding positions -cons1 :: { [ConDecl RdrName] } - : con { [$1] } - | con ';' cons1 { $1:$3 } +qd_occ :: { OccName } + : var_occ { $1 } + | d_occ { $1 } -con :: { ConDecl RdrName } - : q_d_patt attbinds atys - { ConDecl $1 $2 [] (PrefixCon (map unbangedType $3)) noSrcLoc} +--------------------------------------- +-- Binders +bndr :: { IfaceBndr } + : '@' tv_bndr { IfaceTvBndr $2 } + | id_bndr { IfaceIdBndr $1 } -atys :: { [ RdrNameHsType] } - : {- empty -} { [] } - | aty atys { $1:$2 } +bndrs :: { [IfaceBndr] } + : bndr { [$1] } + | bndr bndrs { $1:$2 } -aty :: { RdrNameHsType } - : name { HsTyVar $1 } - | q_tc_name { HsTyVar $1 } - | '(' ty ')' { $2 } +id_bndr :: { IfaceIdBndr } + : '(' var_occ '::' ty ')' { ($2,$4) } +id_bndrs :: { [IfaceIdBndr] } + : {-empty -} { [] } + | id_bndr id_bndrs { $1:$2 } + +tv_bndr :: { IfaceTvBndr } + : tv_occ { ($1, IfaceLiftedTypeKind) } + | '(' tv_occ '::' akind ')' { ($2, $4) } + +tv_bndrs :: { [IfaceTvBndr] } + : {- empty -} { [] } + | tv_bndr tv_bndrs { $1:$2 } + +akind :: { IfaceKind } + : '*' { IfaceLiftedTypeKind } + | '#' { IfaceUnliftedTypeKind } + | '?' { IfaceOpenTypeKind } + | '(' kind ')' { $2 } -bty :: { RdrNameHsType } - : aty { $1 } - | bty aty { HsAppTy $1 $2 } +kind :: { IfaceKind } + : akind { $1 } + | akind '->' kind { IfaceFunKind $1 $3 } -ty :: { RdrNameHsType } - : bty { $1 } - | bty '->' ty { HsFunTy $1 $3 } - | '%forall' tbinds '.' ty { HsForAllTy (Just $2) [] $4 } +----------------------------------------- +-- Expressions -aexp :: { UfExpr RdrName } - : qname { UfVar $1 } - | lit { UfLit $1 } +aexp :: { IfaceExpr } + : var_occ { IfaceLcl $1 } + | modid '.' qd_occ { IfaceExt (ExtPkg $1 $3) } + | lit { IfaceLit $1 } | '(' exp ')' { $2 } -fexp :: { UfExpr RdrName } - : fexp aexp { UfApp $1 $2 } - | fexp '@' aty { UfApp $1 (UfType $3) } +fexp :: { IfaceExpr } + : fexp aexp { IfaceApp $1 $2 } + | fexp '@' aty { IfaceApp $1 (IfaceType $3) } | aexp { $1 } -exp :: { UfExpr RdrName } - : fexp { $1 } - | '\\' binds1 '->' exp { foldr UfLam $4 $2 } - | '%let' let_bind '%in' exp { UfLet $2 $4 } - | '%case' aexp '%of' vbind - '{' alts1 '}' { UfCase $2 (fst $4) $6 } - | '%coerce' aty exp { UfNote (UfCoerce $2) $3 } -- what about the 'from' type? +exp :: { IfaceExpr } + : fexp { $1 } + | '\\' bndrs '->' exp { foldr IfaceLam $4 $2 } + | '%let' let_bind '%in' exp { IfaceLet $2 $4 } + | '%case' aexp '%of' id_bndr + '{' alts1 '}' { IfaceCase $2 (fst $4) $6 } + | '%coerce' aty exp { IfaceNote (IfaceCoerce $2) $3 } | '%note' STRING exp { case $2 of - --"SCC" -> UfNote (UfSCC "scc") $3 - "InlineCall" -> UfNote UfInlineCall $3 - "InlineMe" -> UfNote UfInlineMe $3 + --"SCC" -> IfaceNote (IfaceSCC "scc") $3 + "InlineCall" -> IfaceNote IfaceInlineCall $3 + "InlineMe" -> IfaceNote IfaceInlineMe $3 } - | '%external' STRING aty { UfFCall (ForeignCall.CCall - (CCallSpec (StaticTarget - (mkFastString $2)) - CCallConv (PlaySafe False))) $3 } -alts1 :: { [UfAlt RdrName] } + | '%external' STRING aty { IfaceFCall (ForeignCall.CCall + (CCallSpec (StaticTarget (mkFastString $2)) + CCallConv (PlaySafe False))) + $3 } + +alts1 :: { [IfaceAlt] } : alt { [$1] } | alt ';' alts1 { $1:$3 } -alt :: { UfAlt RdrName } - : q_d_patt attbinds vbinds '->' exp - { (UfDataAlt $1, (map hsTyVarName $2 ++ map fst $3), $5) } +alt :: { IfaceAlt } + : modid '.' d_pat_occ bndrs '->' exp + { (IfaceDataAlt $3, map ifaceBndrName $4, $6) } + -- The external syntax currently includes the types of the + -- the args, but they aren't needed internally + -- Nor is the module qualifier | lit '->' exp - { (UfLitAlt $1, [], $3) } + { (IfaceLitAlt $1, [], $3) } | '%_' '->' exp - { (UfDefault, [], $3) } + { (IfaceDefault, [], $3) } lit :: { Literal } : '(' INTEGER '::' aty ')' { convIntLit $2 $4 } @@ -223,71 +251,76 @@ lit :: { Literal } | '(' CHAR '::' aty ')' { MachChar (fromEnum $2) } | '(' STRING '::' aty ')' { MachStr (mkFastString $2) } -name :: { RdrName } - : NAME { mkRdrUnqual (mkVarOccEncoded (mkFastString $1)) } - -cname :: { String } - : CNAME { $1 } - -mname :: { String } - : CNAME { $1 } +tv_occ :: { OccName } + : NAME { mkSysOcc tvName $1 } -modid :: { ModuleName } - : CNAME { mkSysModuleNameFS (mkFastString $1) } - -qname :: { RdrName } -- Includes data constructors - : name { $1 } - | mname '.' NAME { mkIfaceOrig varName (mkFastString $1) (mkFastString $3) } - | q_d_occ { $1 } +var_occ :: { OccName } + : NAME { mkSysOcc varName $1 } -- Type constructor -q_tc_name :: { RdrName } - : mname '.' cname - { mkIfaceOrig tcName (mkFastString $1) (mkFastString $3) } +q_tc_name :: { IfaceExtName } + : modid '.' CNAME { ExtPkg $1 (mkSysOcc tcName $3) } -- 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) } +d_pat_occ :: { OccName } + : CNAME { mkSysOcc dataName $1 } -- 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) } - +d_occ :: { OccName } + : CNAME { mkSysOcc varName $1 } { -convBind :: RdrNameCoreDecl -> (UfBinder RdrName, UfExpr RdrName) -convBind (CoreDecl n ty rhs _) = (UfValBinder n ty, rhs) - -convIntLit :: Integer -> RdrNameHsType -> Literal -convIntLit i (HsTyVar n) - | n == intPrimRdrName = MachInt i - | n == wordPrimRdrName = MachWord i - | n == charPrimRdrName = MachChar (fromInteger i) - | n == addrPrimRdrName && i == 0 = MachNullAddr -convIntLit i aty - = 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) +ifaceBndrName (IfaceIdBndr (n,_)) = n +ifaceBndrName (IfaceTvBndr (n,_)) = n -wordPrimRdrName, intPrimRdrName, floatPrimRdrName, doublePrimRdrName, addrPrimRdrName :: RdrName -wordPrimRdrName = nameRdrName wordPrimTyConName -intPrimRdrName = nameRdrName intPrimTyConName -charPrimRdrName = nameRdrName charPrimTyConName -floatPrimRdrName = nameRdrName floatPrimTyConName -doublePrimRdrName = nameRdrName doublePrimTyConName -addrPrimRdrName = nameRdrName addrPrimTyConName +convIntLit :: Integer -> IfaceType -> Literal +convIntLit i (IfaceTyConApp tc []) + | tc `eqTc` intPrimTyCon = MachInt i + | tc `eqTc` wordPrimTyCon = MachWord i + | tc `eqTc` charPrimTyCon = MachChar (fromInteger i) + | tc `eqTc` addrPrimTyCon && i == 0 = MachNullAddr +convIntLit i aty + = pprPanic "Unknown integer literal type" (ppr aty) +convRatLit :: Rational -> IfaceType -> Literal +convRatLit r (IfaceTyConApp tc []) + | tc `eqTc` floatPrimTyCon = MachFloat r + | tc `eqTc` doublePrimTyCon = MachDouble r +convRatLit i aty + = pprPanic "Unknown rational literal type" (ppr aty) + +eqTc :: IfaceTyCon -> TyCon -> Bool -- Ugh! +eqTc (IfaceTc (ExtPkg mod occ)) tycon + = mod == nameModuleName nm && occ == nameOccName nm + where + nm = tyConName tycon + +-- Tiresomely, we have to generate both HsTypes (in type/class decls) +-- and IfaceTypes (in Core expressions). So we parse them as IfaceTypes, +-- and convert to HsTypes here. But the IfaceTypes we can see here +-- are very limited (see the productions for 'ty', so the translation +-- isn't hard +toHsType :: IfaceType -> HsType RdrName +toHsType (IfaceTyVar v) = HsTyVar (mkRdrUnqual v) +toHsType (IfaceAppTy t1 t2) = HsAppTy (toHsType t1) (toHsType t2) +toHsType (IfaceFunTy t1 t2) = HsFunTy (toHsType t1) (toHsType t2) +toHsType (IfaceTyConApp (IfaceTc tc) ts) = foldl HsAppTy (HsTyVar (ifaceExtRdrName tc)) (map toHsType ts) +toHsType (IfaceForAllTy tv t) = add_forall (toHsTvBndr tv) (toHsType t) + +toHsTvBndr :: IfaceTvBndr -> HsTyVarBndr RdrName +toHsTvBndr (tv,k) = KindedTyVar (mkRdrUnqual tv) (tcIfaceKind k) + +ifaceExtRdrName :: IfaceExtName -> RdrName +ifaceExtRdrName (ExtPkg mod occ) = mkOrig mod occ +ifaceExtRdrName other = pprPanic "ParserCore.ifaceExtRdrName" (ppr other) + +add_forall tv (HsForAllTy (Just tvs) cxt t) = HsForAllTy (Just (tv:tvs)) cxt t +add_forall tv t = HsForAllTy (Just [tv]) [] t + 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 652a3e658d..4ecdec3559 100644 --- a/ghc/compiler/parser/RdrHsSyn.lhs +++ b/ghc/compiler/parser/RdrHsSyn.lhs @@ -16,7 +16,6 @@ module RdrHsSyn ( RdrNameContext, RdrNameDefaultDecl, RdrNameForeignDecl, - RdrNameCoreDecl, RdrNameGRHS, RdrNameGRHSs, RdrNameHsBinds, @@ -47,15 +46,15 @@ module RdrHsSyn ( main_RDR_Unqual, - extractHsTyRdrNames, extractHsTyRdrTyVars, - extractHsCtxtRdrTyVars, extractGenericPatTyVars, + extractHsTyRdrTyVars, + extractHsRhoRdrTyVars, extractGenericPatTyVars, mkHsOpApp, mkClassDecl, mkHsNegApp, mkNPlusKPat, mkHsIntegral, mkHsFractional, mkHsDo, mkHsSplice, mkSigDecls, mkTyData, mkPrefixCon, mkRecCon, mkRecConstrOrUpdate, -- HsExp -> [HsFieldUpdate] -> P HsExp - mkIfaceExports, -- :: [RdrNameTyClDecl] -> [RdrExportItem] + mkBootIface, cvBinds, cvMonoBindsAndSigs, @@ -94,20 +93,26 @@ module RdrHsSyn ( #include "HsVersions.h" import HsSyn -- Lots of it +import IfaceType +import HscTypes ( ModIface(..), emptyModIface, mkIfaceVerCache ) +import IfaceSyn ( IfaceDecl(..), IfaceIdInfo(..) ) import RdrName ( RdrName, isRdrTyVar, mkRdrUnqual, mkUnqual, rdrNameOcc, isRdrTyVar, isRdrDataCon, isUnqual, getRdrName, isQual, - setRdrNameSpace ) -import BasicTypes ( RecFlag(..), FixitySig(..), maxPrecedence ) -import Class ( DefMeth (..) ) + setRdrNameSpace, rdrNameModule ) +import BasicTypes ( RecFlag(..), mapIPName, maxPrecedence, initialVersion ) import Lexer ( P, setSrcLocFor, getSrcLoc, failLocMsgP ) -import HscTypes ( RdrAvailInfo, GenAvailInfo(..) ) -import TysWiredIn ( unitTyCon ) +import HscTypes ( GenAvailInfo(..) ) +import TysWiredIn ( unitTyCon ) import ForeignCall ( CCallConv, Safety, CCallTarget(..), CExportSpec(..), DNCallSpec(..), DNKind(..)) -import OccName ( srcDataName, varName, isDataOcc, isTcOcc, occNameUserString, - mkDefaultMethodOcc, mkVarOcc ) +import OccName ( OccName, srcDataName, varName, isDataOcc, isTcOcc, + occNameUserString, mkVarOcc, isValOcc ) +import BasicTypes ( initialVersion ) +import TyCon ( DataConDetails(..) ) +import Module ( ModuleName ) import SrcLoc import CStrings ( CLabelString ) +import CmdLineOpts ( opt_InPackage ) import List ( isSuffixOf, nub ) import Outputable import FastString @@ -131,7 +136,6 @@ type RdrNameContext = HsContext RdrName type RdrNameHsDecl = HsDecl RdrName type RdrNameDefaultDecl = DefaultDecl RdrName type RdrNameForeignDecl = ForeignDecl RdrName -type RdrNameCoreDecl = CoreDecl RdrName type RdrNameGRHS = GRHS RdrName type RdrNameGRHSs = GRHSs RdrName type RdrNameHsBinds = HsBinds RdrName @@ -176,24 +180,20 @@ main_RDR_Unqual = mkUnqual varName FSLIT("main") It's used when making the for-alls explicit. \begin{code} -extractHsTyRdrNames :: RdrNameHsType -> [RdrName] -extractHsTyRdrNames ty = nub (extract_ty ty []) - extractHsTyRdrTyVars :: RdrNameHsType -> [RdrName] extractHsTyRdrTyVars ty = nub (filter isRdrTyVar (extract_ty ty [])) -extractHsCtxtRdrNames :: HsContext RdrName -> [RdrName] -extractHsCtxtRdrNames ty = nub (extract_ctxt ty []) -extractHsCtxtRdrTyVars :: HsContext RdrName -> [RdrName] -extractHsCtxtRdrTyVars ty = filter isRdrTyVar (extractHsCtxtRdrNames ty) +extractHsRhoRdrTyVars :: HsContext RdrName -> RdrNameHsType -> [RdrName] +-- This one takes the context and tau-part of a +-- sigma type and returns their free type variables +extractHsRhoRdrTyVars ctxt ty = nub $ filter isRdrTyVar $ + extract_ctxt ctxt (extract_ty ty []) extract_ctxt ctxt acc = foldr extract_pred acc ctxt extract_pred (HsClassP cls tys) acc = foldr extract_ty (cls : acc) tys extract_pred (HsIParam n ty) acc = extract_ty ty acc -extract_tys tys = foldr extract_ty [] tys - extract_ty (HsAppTy ty1 ty2) acc = extract_ty ty1 (extract_ty ty2 acc) extract_ty (HsListTy ty) acc = extract_ty ty acc extract_ty (HsPArrTy ty) acc = extract_ty ty acc @@ -249,22 +249,14 @@ Similarly for mkConDecl, mkClassOpSig and default-method names. mkClassDecl (cxt, cname, tyvars) fds sigs mbinds loc = ClassDecl { tcdCtxt = cxt, tcdName = cname, tcdTyVars = tyvars, tcdFDs = fds, - tcdSigs = map cvClassOpSig sigs, -- Convert to class-op sigs + tcdSigs = sigs, tcdMeths = mbinds, tcdLoc = loc } mkTyData new_or_data (context, tname, tyvars) data_cons maybe src = TyData { tcdND = new_or_data, tcdCtxt = context, tcdName = tname, tcdTyVars = tyvars, tcdCons = data_cons, - tcdDerivs = maybe, tcdLoc = src, tcdGeneric = Nothing } - -cvClassOpSig :: RdrNameSig -> RdrNameSig -cvClassOpSig (Sig var poly_ty src_loc) - = ClassOpSig var (DefMeth dm_rn) poly_ty src_loc - where - dm_rn = mkRdrUnqual (mkDefaultMethodOcc (rdrNameOcc var)) -cvClassOpSig sig - = sig + tcdDerivs = maybe, tcdLoc = src } \end{code} \begin{code} @@ -276,7 +268,7 @@ mkHsNegApp :: RdrNameHsExpr -> RdrNameHsExpr mkHsNegApp (HsLit (HsIntPrim i)) = HsLit (HsIntPrim (-i)) mkHsNegApp (HsLit (HsFloatPrim i)) = HsLit (HsFloatPrim (-i)) mkHsNegApp (HsLit (HsDoublePrim i)) = HsLit (HsDoublePrim (-i)) -mkHsNegApp expr = NegApp expr placeHolderName +mkHsNegApp expr = NegApp expr placeHolderName \end{code} A useful function for building @OpApps@. The operator is always a @@ -306,6 +298,143 @@ unqualSplice = mkRdrUnqual (mkVarOcc FSLIT("splice")) %************************************************************************ %* * + Hi-boot files +%* * +%************************************************************************ + +mkBootIface, and its boring helper functions, have two purposes: +a) HsSyn to IfaceSyn. The parser parses the former, but we're reading + an hi-boot file, and interfaces consist of the latter +b) Convert unqualifed names from the "current module" to qualified Orig + names. E.g. + module This where + foo :: GHC.Base.Int -> GHC.Base.Int + becomes + This.foo :: GHC.Base.Int -> GHC.Base.Int + +It assumes that everything is well kinded, of course. + +\begin{code} +mkBootIface :: ModuleName -> [HsDecl RdrName] -> ModIface +-- Make the ModIface for a hi-boot file +-- The decls are of very limited form +mkBootIface mod decls + = (emptyModIface opt_InPackage mod) { + mi_boot = True, + mi_exports = [(mod, map mk_export decls')], + mi_decls = decls_w_vers, + mi_ver_fn = mkIfaceVerCache decls_w_vers } + where + decls' = map hsIfaceDecl decls + decls_w_vers = repeat initialVersion `zip` decls' + + -- hi-boot declarations don't (currently) + -- expose constructors or class methods + mk_export decl | isValOcc occ = Avail occ + | otherwise = AvailTC occ [occ] + where + occ = ifName decl + + +hsIfaceDecl :: HsDecl RdrName -> IfaceDecl + -- Change to Iface syntax, and replace unqualified names with + -- qualified Orig names from this module. Reason: normal + -- iface files have everything fully qualified, so it's convenient + -- for hi-boot files to look the same + -- + -- NB: no constructors or class ops to worry about +hsIfaceDecl (SigD (Sig name ty _)) + = IfaceId { ifName = rdrNameOcc name, + ifType = hsIfaceType ty, + ifIdInfo = NoInfo } + +hsIfaceDecl (TyClD decl@(TySynonym {})) + = IfaceSyn { ifName = rdrNameOcc (tcdName decl), + ifTyVars = hsIfaceTvs (tcdTyVars decl), + ifSynRhs = hsIfaceType (tcdSynRhs decl), + ifVrcs = [] } + +hsIfaceDecl (TyClD decl@(TyData {})) + = IfaceData { ifND = tcdND decl, + ifName = rdrNameOcc (tcdName decl), + ifTyVars = hsIfaceTvs (tcdTyVars decl), + ifCtxt = hsIfaceCtxt (tcdCtxt decl), + ifCons = Unknown, ifRec = NonRecursive, + ifVrcs = [], ifGeneric = False } + +hsIfaceDecl (TyClD decl@(ClassDecl {})) + = IfaceClass { ifName = rdrNameOcc (tcdName decl), + ifTyVars = hsIfaceTvs (tcdTyVars decl), + ifCtxt = hsIfaceCtxt (tcdCtxt decl), + ifFDs = hsIfaceFDs (tcdFDs decl), + ifSigs = [], -- Is this right?? + ifRec = NonRecursive, ifVrcs = [] } + +hsIfaceDecl decl = pprPanic "hsIfaceDecl" (ppr decl) + +hsIfaceName rdr_name -- Qualify unqualifed occurrences + -- with the module name + | isUnqual rdr_name = LocalTop (rdrNameOcc rdr_name) + | otherwise = ExtPkg (rdrNameModule rdr_name) (rdrNameOcc rdr_name) + +hsIfaceType :: HsType RdrName -> IfaceType +hsIfaceType (HsForAllTy mb_tvs cxt ty) + = foldr (IfaceForAllTy . hsIfaceTv) rho tvs + where + rho = foldr (IfaceFunTy . IfacePredTy . hsIfacePred) tau cxt + tau = hsIfaceType ty + tvs = case mb_tvs of + Just tvs -> tvs + Nothing -> map UserTyVar (extractHsRhoRdrTyVars cxt ty) + +hsIfaceType ty@(HsTyVar _) = hs_tc_app ty [] +hsIfaceType ty@(HsAppTy t1 t2) = hs_tc_app ty [] +hsIfaceType (HsFunTy t1 t2) = IfaceFunTy (hsIfaceType t1) (hsIfaceType t2) +hsIfaceType (HsListTy t) = IfaceTyConApp IfaceListTc [hsIfaceType t] +hsIfaceType (HsPArrTy t) = IfaceTyConApp IfacePArrTc [hsIfaceType t] +hsIfaceType (HsTupleTy bx ts) = IfaceTyConApp (IfaceTupTc bx (length ts)) (hsIfaceTypes ts) +hsIfaceType (HsOpTy t1 tc t2) = hs_tc_app (HsTyVar tc) (hsIfaceTypes [t1, t2]) +hsIfaceType (HsParTy t) = hsIfaceType t +hsIfaceType (HsNumTy n) = panic "hsIfaceType:HsNum" +hsIfaceType (HsPredTy p) = IfacePredTy (hsIfacePred p) +hsIfaceType (HsKindSig t _) = hsIfaceType t + +----------- +hsIfaceTypes tys = map hsIfaceType tys + +----------- +hsIfaceCtxt :: [HsPred RdrName] -> [IfacePredType] +hsIfaceCtxt ctxt = map hsIfacePred ctxt + +----------- +hsIfacePred :: HsPred RdrName -> IfacePredType +hsIfacePred (HsClassP cls ts) = IfaceClassP (hsIfaceName cls) (hsIfaceTypes ts) +hsIfacePred (HsIParam ip t) = IfaceIParam (mapIPName rdrNameOcc ip) (hsIfaceType t) + +----------- +hs_tc_app :: HsType RdrName -> [IfaceType] -> IfaceType +hs_tc_app (HsAppTy t1 t2) args = hs_tc_app t1 (hsIfaceType t2 : args) +hs_tc_app (HsTyVar n) args + | isTcOcc (rdrNameOcc n) = IfaceTyConApp (IfaceTc (hsIfaceName n)) args + | otherwise = foldl IfaceAppTy (IfaceTyVar (rdrNameOcc n)) args +hs_tc_app ty args = foldl IfaceAppTy (hsIfaceType ty) args + +----------- +hsIfaceTvs tvs = map hsIfaceTv tvs + +----------- +hsIfaceTv (UserTyVar n) = (rdrNameOcc n, IfaceLiftedTypeKind) +hsIfaceTv (KindedTyVar n k) = (rdrNameOcc n, toIfaceKind k) + +----------- +hsIfaceFDs :: [([RdrName], [RdrName])] -> [([OccName], [OccName])] +hsIfaceFDs fds = [ (map rdrNameOcc xs, map rdrNameOcc ys) + | (xs,ys) <- fds ] +\end{code} + + +%************************************************************************ +%* * \subsection[rdrBinding]{Bindings straight out of the parser} %* * %************************************************************************ @@ -416,7 +545,7 @@ emptyGroup = HsGroup { hs_valds = MonoBind EmptyMonoBinds [] Recursive, -- they start life as a single giant MonoBinds hs_tyclds = [], hs_instds = [], hs_fixds = [], hs_defds = [], hs_fords = [], - hs_depds = [] ,hs_ruleds = [], hs_coreds = [] } + hs_depds = [] ,hs_ruleds = [] } findSplice :: [HsDecl a] -> (HsGroup a, Maybe (SpliceDecl a, [HsDecl a])) findSplice ds = add emptyGroup ds @@ -456,7 +585,6 @@ add gp@(HsGroup {hs_defds = ts}) (DefD d : ds) = add (gp { hs_defds = d : ts add gp@(HsGroup {hs_fords = ts}) (ForD d : ds) = add (gp { hs_fords = d : ts }) ds add gp@(HsGroup {hs_depds = ts}) (DeprecD d : ds) = add (gp { hs_depds = d : ts }) ds add gp@(HsGroup {hs_ruleds = ts})(RuleD d : ds) = add (gp { hs_ruleds = d : ts }) ds -add gp@(HsGroup {hs_coreds = ts})(CoreD d : ds) = add (gp { hs_coreds = d : ts }) ds add_bind b (MonoBind bs sigs r) = MonoBind (bs `AndMonoBinds` b) sigs r add_sig s (MonoBind bs sigs r) = MonoBind bs (s:sigs) r @@ -520,29 +648,37 @@ checkTyVars tvs = mapM chk tvs where -- Check that the name space is correct! - chk (HsKindSig (HsTyVar tv) k) | isRdrTyVar tv = return (IfaceTyVar tv k) + chk (HsKindSig (HsTyVar tv) k) | isRdrTyVar tv = return (KindedTyVar tv k) chk (HsTyVar tv) | isRdrTyVar tv = return (UserTyVar tv) chk other = parseError "Type found where type variable expected" -checkTyClHdr :: RdrNameHsType -> P (RdrName, [RdrNameHsTyVar]) +checkTyClHdr :: RdrNameContext -> RdrNameHsType -> P (RdrNameContext, RdrName, [RdrNameHsTyVar]) -- The header of a type or class decl should look like -- (C a, D b) => T a b -- or T a b -- or a + b -- etc -checkTyClHdr ty - = go ty [] +checkTyClHdr cxt ty + = go ty [] >>= \ (tc, tvs) -> + mapM chk_pred cxt >>= \ _ -> + return (cxt, tc, tvs) where go (HsTyVar tc) acc | not (isRdrTyVar tc) = checkTyVars acc >>= \ tvs -> return (tc, tvs) - go (HsOpTy t1 (HsTyOp tc) t2) acc - = checkTyVars (t1:t2:acc) >>= \ tvs -> + go (HsOpTy t1 tc t2) acc = checkTyVars (t1:t2:acc) >>= \ tvs -> return (tc, tvs) go (HsParTy ty) acc = go ty acc go (HsAppTy t1 t2) acc = go t1 (t2:acc) go other acc = parseError "Malformed LHS to type of class declaration" + -- The predicates in a type or class decl must all + -- be HsClassPs. They need not all be type variables, + -- even in Haskell 98. E.g. class (Monad m, Monad (t m)) => MonadT t m + chk_pred (HsClassP _ args) = return () + chk_pred pred = parseError "Malformed context in type or class declaration" + + checkContext :: RdrNameHsType -> P RdrNameContext checkContext (HsTupleTy _ ts) -- (Eq a, Ord b) shows up as a tuple type = mapM checkPred ts @@ -617,8 +753,15 @@ checkPat e [] = case e of EWildPat -> return (WildPat placeHolderType) HsVar x | isQual x -> parseError ("Qualified variable in pattern: " ++ showRdrName x) | otherwise -> return (VarPat x) - HsLit l -> return (LitPat l) - HsOverLit l -> return (NPatIn l Nothing) + HsLit l -> return (LitPat l) + + -- Overloaded numeric patterns (e.g. f 0 x = x) + -- Negation is recorded separately, so that the literal is zero or +ve + -- NB. Negative *primitive* literals are already handled by + -- RdrHsSyn.mkHsNegApp + HsOverLit pos_lit -> return (NPatIn pos_lit Nothing) + NegApp (HsOverLit pos_lit) _ -> return (NPatIn pos_lit (Just placeHolderName)) + ELazyPat e -> checkPat e [] >>= (return . LazyPat) EAsPat n e -> checkPat e [] >>= (return . AsPat n) ExprWithTySig e t -> checkPat e [] >>= \e -> @@ -631,13 +774,7 @@ checkPat e [] = case e of in return (SigPatIn e t') - -- Translate out NegApps of literals in patterns. We negate - -- the Integer here, and add back the call to 'negate' when - -- we typecheck the pattern. - -- NB. Negative *primitive* literals are already handled by - -- RdrHsSyn.mkHsNegApp - NegApp (HsOverLit lit) neg -> return (NPatIn lit (Just neg)) - + -- n+k patterns OpApp (HsVar n) (HsVar plus) _ (HsOverLit lit@(HsIntegral _ _)) | plus == plus_RDR -> return (mkNPlusKPat n lit) @@ -884,20 +1021,6 @@ mkExport DNCall (entity, v, ty) loc = -- mkExtName :: RdrName -> CLabelString mkExtName rdrNm = mkFastString (occNameUserString (rdrNameOcc rdrNm)) - --- --------------------------------------------------------------------------- --- Make the export list for an interface - -mkIfaceExports :: [RdrNameTyClDecl] -> [RdrAvailInfo] -mkIfaceExports decls = map getExport decls - where getExport d = case d of - TyData{} -> tc_export - ClassDecl{} -> tc_export - _other -> var_export - where - tc_export = AvailTC (rdrNameOcc (tcdName d)) - (map (rdrNameOcc.fst) (tyClDeclNames d)) - var_export = Avail (rdrNameOcc (tcdName d)) \end{code} diff --git a/ghc/compiler/prelude/PrelInfo.lhs b/ghc/compiler/prelude/PrelInfo.lhs index c6afe14b79..36b9520eef 100644 --- a/ghc/compiler/prelude/PrelInfo.lhs +++ b/ghc/compiler/prelude/PrelInfo.lhs @@ -5,12 +5,11 @@ \begin{code} module PrelInfo ( - module PrelNames, module MkId, - wiredInThingEnv, ghcPrimExports, - knownKeyNames, + wiredInThings, basicKnownKeyNames, + primOpId, -- Random other things maybeCharLikeCon, maybeIntLikeCon, @@ -26,28 +25,22 @@ import PrelNames ( basicKnownKeyNames, hasKey, charDataConKey, intDataConKey, numericClassKeys, standardClassKeys, noDictClassKeys ) -#ifdef GHCI -import DsMeta ( templateHaskellNames ) -import NameSet ( nameSetToList ) -#endif -import PrimOp ( allThePrimOps, primOpOcc ) +import PrimOp ( PrimOp, allThePrimOps, primOpOcc, primOpTag, maxPrimOpTag ) import DataCon ( DataCon ) -import Id ( idName ) +import Id ( Id, idName ) import MkId ( mkPrimOpId, wiredInIds ) import MkId -- All of it, for re-export -import Name ( Name, nameOccName, NamedThing(..) ) -import RdrName ( mkRdrUnqual ) -import HsSyn ( HsTyVarBndr(..) ) -import OccName ( mkVarOcc ) +import Name ( nameOccName ) import TysPrim ( primTyCons ) import TysWiredIn ( wiredInTyCons ) -import HscTypes ( TyThing(..), implicitTyThings, TypeEnv, mkTypeEnv, - GenAvailInfo(..), RdrAvailInfo ) -import Class ( Class, classKey, className ) -import Type ( funTyCon, openTypeKind, liftedTypeKind ) +import HscTypes ( TyThing(..), implicitTyThings, GenAvailInfo(..), RdrAvailInfo ) +import Class ( Class, classKey ) +import Type ( funTyCon ) import TyCon ( tyConName ) import Util ( isIn ) + +import Array ( Array, array, (!) ) \end{code} %************************************************************************ @@ -61,11 +54,11 @@ We have two ``builtin name funs,'' one to look up @TyCons@ and \begin{code} wiredInThings :: [TyThing] -wiredInThings +wiredInThings = concat [ -- Wired in TyCons and their implicit Ids tycon_things - , implicitTyThings tycon_things + , concatMap implicitTyThings tycon_things -- Wired in Ids , map AnId wiredInIds @@ -75,17 +68,6 @@ wiredInThings ] where tycon_things = map ATyCon ([funTyCon] ++ primTyCons ++ wiredInTyCons) - -wiredInThingEnv :: TypeEnv -wiredInThingEnv = mkTypeEnv wiredInThings - -knownKeyNames :: [Name] -knownKeyNames - = map getName wiredInThings - ++ basicKnownKeyNames -#ifdef GHCI - ++ nameSetToList templateHaskellNames -#endif \end{code} We let a lot of "non-standard" values be visible, so that we can make @@ -94,6 +76,22 @@ sense of them in interface pragmas. It's cool, though they all have %************************************************************************ %* * + PrimOpIds +%* * +%************************************************************************ + +\begin{code} +primOpIds :: Array Int Id -- Indexed by PrimOp tag +primOpIds = array (1,maxPrimOpTag) [ (primOpTag op, mkPrimOpId op) + | op <- allThePrimOps] + +primOpId :: PrimOp -> Id +primOpId op = primOpIds ! primOpTag op +\end{code} + + +%************************************************************************ +%* * \subsection{Export lists for pseudo-modules (GHC.Prim)} %* * %************************************************************************ @@ -108,10 +106,6 @@ ghcPrimExports :: [RdrAvailInfo] [ AvailTC occ [occ] | n <- funTyCon : primTyCons, let occ = nameOccName (tyConName n) ] - -alpha = mkRdrUnqual (mkVarOcc FSLIT("a")) -openAlpha = IfaceTyVar alpha openTypeKind -liftedAlpha = IfaceTyVar alpha liftedTypeKind \end{code} diff --git a/ghc/compiler/prelude/PrelNames.lhs b/ghc/compiler/prelude/PrelNames.lhs index 4c8f926f84..e2e250f36b 100644 --- a/ghc/compiler/prelude/PrelNames.lhs +++ b/ghc/compiler/prelude/PrelNames.lhs @@ -49,9 +49,8 @@ module PrelNames ( #include "HsVersions.h" -import Module ( ModuleName, mkBasePkgModule, mkHomeModule, mkModuleName ) -import OccName ( UserFS, dataName, tcName, clsName, varName, - mkKindOccFS, mkOccFS +import Module ( Module, mkBasePkgModule, mkHomeModule, mkModuleName ) +import OccName ( dataName, tcName, clsName, varName, mkOccFS ) import RdrName ( RdrName, nameRdrName, mkOrig, rdrNameOcc ) @@ -60,11 +59,9 @@ import Unique ( Unique, Uniquable(..), hasKey, mkPreludeTyConUnique, mkPreludeClassUnique, mkTupleTyConUnique, isTupleKey ) -import BasicTypes ( Boxity(..) ) -import Name ( Name, mkInternalName, mkKnownKeyExternalName, mkWiredInName, nameUnique ) +import BasicTypes ( Boxity(..), Arity ) +import Name ( Name, mkInternalName, mkExternalName, nameUnique, nameModule ) import SrcLoc ( noSrcLoc ) -import Util ( nOfThem ) -import Panic ( panic ) import FastString @@ -126,7 +123,9 @@ wired in ones are defined in TysWiredIn etc. \begin{code} basicKnownKeyNames :: [Name] basicKnownKeyNames - = [ -- Type constructors (synonyms especially) + = genericTyConNames + ++ monadNames + ++ [ -- Type constructors (synonyms especially) ioTyConName, ioDataConName, runIOName, orderingTyConName, @@ -135,7 +134,7 @@ basicKnownKeyNames ratioTyConName, byteArrayTyConName, mutableByteArrayTyConName, - bcoPrimTyConName, + integerTyConName, smallIntegerDataConName, largeIntegerDataConName, -- Classes. *Must* include: -- classes that are grabbed by key (e.g., eqClassKey) @@ -167,7 +166,6 @@ basicKnownKeyNames enumFromToPName, enumFromThenToPName, -- Monad stuff - thenMName, bindMName, returnMName, failMName, thenIOName, bindIOName, returnIOName, failIOName, -- MonadRec stuff @@ -205,14 +203,13 @@ basicKnownKeyNames -- FFI primitive types that are not wired-in. stablePtrTyConName, ptrTyConName, funPtrTyConName, addrTyConName, int8TyConName, int16TyConName, int32TyConName, int64TyConName, - word8TyConName, word16TyConName, word32TyConName, word64TyConName, + wordTyConName, word8TyConName, word16TyConName, word32TyConName, word64TyConName, -- Others - unsafeCoerceName, otherwiseIdName, + otherwiseIdName, plusIntegerName, timesIntegerName, - eqStringName, assertName, assertErrorName, runSTRepName, + eqStringName, assertName, runSTRepName, printName, splitName, fstName, sndName, - errorName, -- Booleans andName, orName @@ -227,6 +224,9 @@ basicKnownKeyNames monadNames :: [Name] -- The monad ops need by a HsDo monadNames = [returnMName, failMName, bindMName, thenMName] + +genericTyConNames :: [Name] +genericTyConNames = [crossTyConName, plusTyConName, genUnitTyConName] \end{code} @@ -283,16 +283,37 @@ gLA_EXTS_Name = mkModuleName "GHC.Exts" gHC_PRIM = mkBasePkgModule gHC_PRIM_Name pREL_BASE = mkBasePkgModule pREL_BASE_Name +pREL_TUP = mkBasePkgModule pREL_TUP_Name +pREL_EITHER = mkBasePkgModule pREL_EITHER_Name +pREL_LIST = mkBasePkgModule pREL_LIST_Name +pREL_SHOW = mkBasePkgModule pREL_SHOW_Name +pREL_READ = mkBasePkgModule pREL_READ_Name pREL_ADDR = mkBasePkgModule pREL_ADDR_Name +pREL_WORD = mkBasePkgModule pREL_WORD_Name +pREL_INT = mkBasePkgModule pREL_INT_Name pREL_PTR = mkBasePkgModule pREL_PTR_Name +pREL_ST = mkBasePkgModule pREL_ST_Name pREL_STABLE = mkBasePkgModule pREL_STABLE_Name pREL_IO_BASE = mkBasePkgModule pREL_IO_BASE_Name pREL_PACK = mkBasePkgModule pREL_PACK_Name pREL_ERR = mkBasePkgModule pREL_ERR_Name pREL_NUM = mkBasePkgModule pREL_NUM_Name +pREL_ENUM = mkBasePkgModule pREL_ENUM_Name pREL_REAL = mkBasePkgModule pREL_REAL_Name pREL_FLOAT = mkBasePkgModule pREL_FLOAT_Name +pREL_ARR = mkBasePkgModule pREL_ARR_Name +pREL_PARR = mkBasePkgModule pREL_PARR_Name +pREL_BYTEARR = mkBasePkgModule pREL_BYTEARR_Name +pREL_TOP_HANDLER= mkBasePkgModule pREL_TOP_HANDLER_Name pRELUDE = mkBasePkgModule pRELUDE_Name +sYSTEM_IO = mkBasePkgModule sYSTEM_IO_Name +aDDR = mkBasePkgModule aDDR_Name +aRROW = mkBasePkgModule aRROW_Name +gENERICS = mkBasePkgModule gENERICS_Name +tYPEABLE = mkBasePkgModule tYPEABLE_Name +dOTNET = mkBasePkgModule dOTNET_Name +gLA_EXTS = mkBasePkgModule gLA_EXTS_Name +mONAD_FIX = mkBasePkgModule mONAD_FIX_Name -- MetaHaskell Extension text2 from Meta/work/gen.hs mETA_META_Name = mkModuleName "Language.Haskell.THSyntax" @@ -313,22 +334,10 @@ iNTERACTIVE = mkHomeModule (mkModuleName ":Interactive") %************************************************************************ \begin{code} -mkTupNameStr :: Boxity -> Int -> (ModuleName, UserFS) - -mkTupNameStr Boxed 0 = (pREL_BASE_Name, FSLIT("()")) -mkTupNameStr Boxed 1 = panic "Name.mkTupNameStr: 1 ???" -mkTupNameStr Boxed 2 = (pREL_TUP_Name, mkFastString "(,)") -- not strictly necessary -mkTupNameStr Boxed 3 = (pREL_TUP_Name, mkFastString "(,,)") -- ditto -mkTupNameStr Boxed 4 = (pREL_TUP_Name, mkFastString "(,,,)") -- ditto -mkTupNameStr Boxed n = (pREL_TUP_Name, mkFastString ("(" ++ nOfThem (n-1) ',' ++ ")")) - -mkTupNameStr Unboxed 0 = (gHC_PRIM_Name, mkFastString "(# #)") -- 1 and 0 both make sense!!! ---panic "Name.mkUbxTupNameStr: 0 ???" -mkTupNameStr Unboxed 1 = (gHC_PRIM_Name, mkFastString "(# #)") -- 1 and 0 both make sense!!! -mkTupNameStr Unboxed 2 = (gHC_PRIM_Name, mkFastString "(#,#)") -mkTupNameStr Unboxed 3 = (gHC_PRIM_Name, mkFastString "(#,,#)") -mkTupNameStr Unboxed 4 = (gHC_PRIM_Name, mkFastString "(#,,,#)") -mkTupNameStr Unboxed n = (gHC_PRIM_Name, mkFastString ("(#" ++ nOfThem (n-1) ',' ++ "#)")) +mkTupleModule :: Boxity -> Arity -> Module +mkTupleModule Boxed 0 = pREL_BASE +mkTupleModule Boxed _ = pREL_TUP +mkTupleModule Unboxed _ = gHC_PRIM \end{code} @@ -364,18 +373,13 @@ returnM_RDR = nameRdrName returnMName bindM_RDR = nameRdrName bindMName failM_RDR = nameRdrName failMName -false_RDR = nameRdrName falseDataConName -true_RDR = nameRdrName trueDataConName and_RDR = nameRdrName andName left_RDR = nameRdrName leftDataConName right_RDR = nameRdrName rightDataConName -error_RDR = nameRdrName errorName - fromEnum_RDR = varQual_RDR pREL_ENUM_Name FSLIT("fromEnum") toEnum_RDR = varQual_RDR pREL_ENUM_Name FSLIT("toEnum") -mkInt_RDR = nameRdrName intDataConName enumFrom_RDR = nameRdrName enumFromName enumFromTo_RDR = nameRdrName enumFromToName @@ -395,6 +399,7 @@ unpackCStringUtf8_RDR = nameRdrName unpackCStringUtf8Name newStablePtr_RDR = nameRdrName newStablePtrName addrDataCon_RDR = dataQual_RDR aDDR_Name FSLIT("A#") +wordDataCon_RDR = dataQual_RDR pREL_WORD_Name FSLIT("W#") bindIO_RDR = nameRdrName bindIOName returnIO_RDR = nameRdrName returnIOName @@ -447,8 +452,18 @@ mkTypeRep_RDR = varQual_RDR tYPEABLE_Name FSLIT("mkAppTy") mkTyConRep_RDR = varQual_RDR tYPEABLE_Name FSLIT("mkTyCon") undefined_RDR = varQual_RDR pREL_ERR_Name FSLIT("undefined") -\end{code} +crossDataCon_RDR = dataQual_RDR pREL_BASE_Name FSLIT(":*:") +inlDataCon_RDR = dataQual_RDR pREL_BASE_Name FSLIT("Inl") +inrDataCon_RDR = dataQual_RDR pREL_BASE_Name FSLIT("Inr") +genUnitDataCon_RDR = dataQual_RDR pREL_BASE_Name FSLIT("Unit") + +---------------------- +varQual_RDR mod str = mkOrig mod (mkOccFS varName 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) +\end{code} %************************************************************************ %* * @@ -465,261 +480,191 @@ and it's convenient to write them all down in one place. \begin{code} -rootMainName = varQual rOOT_MAIN_Name FSLIT("main") rootMainKey -runIOName = varQual pREL_TOP_HANDLER_Name FSLIT("runIO") runMainKey - --- Stuff from GHC.Prim -superKindName = kindQual FSLIT("KX") kindConKey -superBoxityName = kindQual FSLIT("BX") boxityConKey -liftedConName = kindQual FSLIT("*") liftedConKey -unliftedConName = kindQual FSLIT("#") unliftedConKey -openKindConName = kindQual FSLIT("?") anyBoxConKey -typeConName = kindQual FSLIT("Type") typeConKey - -funTyConName = tcQual gHC_PRIM_Name FSLIT("(->)") funTyConKey -charPrimTyConName = tcQual gHC_PRIM_Name FSLIT("Char#") charPrimTyConKey -intPrimTyConName = tcQual gHC_PRIM_Name FSLIT("Int#") intPrimTyConKey -int32PrimTyConName = tcQual gHC_PRIM_Name FSLIT("Int32#") int32PrimTyConKey -int64PrimTyConName = tcQual gHC_PRIM_Name FSLIT("Int64#") int64PrimTyConKey -wordPrimTyConName = tcQual gHC_PRIM_Name FSLIT("Word#") wordPrimTyConKey -word32PrimTyConName = tcQual gHC_PRIM_Name FSLIT("Word32#") word32PrimTyConKey -word64PrimTyConName = tcQual gHC_PRIM_Name FSLIT("Word64#") word64PrimTyConKey -addrPrimTyConName = tcQual gHC_PRIM_Name FSLIT("Addr#") addrPrimTyConKey -floatPrimTyConName = tcQual gHC_PRIM_Name FSLIT("Float#") floatPrimTyConKey -doublePrimTyConName = tcQual gHC_PRIM_Name FSLIT("Double#") doublePrimTyConKey -statePrimTyConName = tcQual gHC_PRIM_Name FSLIT("State#") statePrimTyConKey -realWorldTyConName = tcQual gHC_PRIM_Name FSLIT("RealWorld") realWorldTyConKey -arrayPrimTyConName = tcQual gHC_PRIM_Name FSLIT("Array#") arrayPrimTyConKey -byteArrayPrimTyConName = tcQual gHC_PRIM_Name FSLIT("ByteArray#") byteArrayPrimTyConKey -mutableArrayPrimTyConName = tcQual gHC_PRIM_Name FSLIT("MutableArray#") mutableArrayPrimTyConKey -mutableByteArrayPrimTyConName = tcQual gHC_PRIM_Name FSLIT("MutableByteArray#") mutableByteArrayPrimTyConKey -mutVarPrimTyConName = tcQual gHC_PRIM_Name FSLIT("MutVar#") mutVarPrimTyConKey -mVarPrimTyConName = tcQual gHC_PRIM_Name FSLIT("MVar#") mVarPrimTyConKey -stablePtrPrimTyConName = tcQual gHC_PRIM_Name FSLIT("StablePtr#") stablePtrPrimTyConKey -stableNamePrimTyConName = tcQual gHC_PRIM_Name FSLIT("StableName#") stableNamePrimTyConKey -foreignObjPrimTyConName = tcQual gHC_PRIM_Name FSLIT("ForeignObj#") foreignObjPrimTyConKey -bcoPrimTyConName = tcQual gHC_PRIM_Name FSLIT("BCO#") bcoPrimTyConKey -weakPrimTyConName = tcQual gHC_PRIM_Name FSLIT("Weak#") weakPrimTyConKey -threadIdPrimTyConName = tcQual gHC_PRIM_Name FSLIT("ThreadId#") threadIdPrimTyConKey - -unsafeCoerceName = wVarQual gHC_PRIM_Name FSLIT("unsafeCoerce#") unsafeCoerceIdKey -nullAddrName = wVarQual gHC_PRIM_Name FSLIT("nullAddr#") nullAddrIdKey -seqName = wVarQual gHC_PRIM_Name FSLIT("seq") seqIdKey -realWorldName = wVarQual gHC_PRIM_Name FSLIT("realWorld#") realWorldPrimIdKey - --- PrelBase data types and constructors -charTyConName = wTcQual pREL_BASE_Name FSLIT("Char") charTyConKey -charDataConName = wDataQual pREL_BASE_Name FSLIT("C#") charDataConKey -intTyConName = wTcQual pREL_BASE_Name FSLIT("Int") intTyConKey -intDataConName = wDataQual pREL_BASE_Name FSLIT("I#") intDataConKey -orderingTyConName = tcQual pREL_BASE_Name FSLIT("Ordering") orderingTyConKey -boolTyConName = wTcQual pREL_BASE_Name FSLIT("Bool") boolTyConKey -falseDataConName = wDataQual pREL_BASE_Name FSLIT("False") falseDataConKey -trueDataConName = wDataQual pREL_BASE_Name FSLIT("True") trueDataConKey -listTyConName = wTcQual pREL_BASE_Name FSLIT("[]") listTyConKey -nilDataConName = wDataQual pREL_BASE_Name FSLIT("[]") nilDataConKey -consDataConName = wDataQual pREL_BASE_Name FSLIT(":") consDataConKey -eqName = varQual pREL_BASE_Name FSLIT("==") eqClassOpKey -geName = varQual pREL_BASE_Name FSLIT(">=") geClassOpKey - -eitherTyConName = tcQual pREL_EITHER_Name FSLIT("Either") eitherTyConKey -leftDataConName = dataQual pREL_EITHER_Name FSLIT("Left") leftDataConKey -rightDataConName = dataQual pREL_EITHER_Name FSLIT("Right") rightDataConKey +rootMainName = varQual rOOT_MAIN FSLIT("main") rootMainKey +runIOName = varQual pREL_TOP_HANDLER FSLIT("runIO") runMainKey + +orderingTyConName = tcQual pREL_BASE FSLIT("Ordering") orderingTyConKey + +eitherTyConName = tcQual pREL_EITHER FSLIT("Either") eitherTyConKey +leftDataConName = conName eitherTyConName FSLIT("Left") leftDataConKey +rightDataConName = conName eitherTyConName FSLIT("Right") rightDataConKey -- Generics -crossTyConName = tcQual pREL_BASE_Name FSLIT(":*:") crossTyConKey -crossDataConName = dataQual pREL_BASE_Name FSLIT(":*:") crossDataConKey -plusTyConName = wTcQual pREL_BASE_Name FSLIT(":+:") plusTyConKey -inlDataConName = wDataQual pREL_BASE_Name FSLIT("Inl") inlDataConKey -inrDataConName = wDataQual pREL_BASE_Name FSLIT("Inr") inrDataConKey -genUnitTyConName = wTcQual pREL_BASE_Name FSLIT("Unit") genUnitTyConKey -genUnitDataConName = wDataQual pREL_BASE_Name FSLIT("Unit") genUnitDataConKey +crossTyConName = tcQual pREL_BASE FSLIT(":*:") crossTyConKey +plusTyConName = tcQual pREL_BASE FSLIT(":+:") plusTyConKey +genUnitTyConName = tcQual pREL_BASE FSLIT("Unit") genUnitTyConKey -- Base strings Strings -unpackCStringName = varQual pREL_BASE_Name FSLIT("unpackCString#") unpackCStringIdKey -unpackCStringAppendName = varQual pREL_BASE_Name FSLIT("unpackAppendCString#") unpackCStringAppendIdKey -unpackCStringFoldrName = varQual pREL_BASE_Name FSLIT("unpackFoldrCString#") unpackCStringFoldrIdKey -unpackCStringUtf8Name = varQual pREL_BASE_Name FSLIT("unpackCStringUtf8#") unpackCStringUtf8IdKey -eqStringName = varQual pREL_BASE_Name FSLIT("eqString") eqStringIdKey +unpackCStringName = varQual pREL_BASE FSLIT("unpackCString#") unpackCStringIdKey +unpackCStringAppendName = varQual pREL_BASE FSLIT("unpackAppendCString#") unpackCStringAppendIdKey +unpackCStringFoldrName = varQual pREL_BASE FSLIT("unpackFoldrCString#") unpackCStringFoldrIdKey +unpackCStringUtf8Name = varQual pREL_BASE FSLIT("unpackCStringUtf8#") unpackCStringUtf8IdKey +eqStringName = varQual pREL_BASE FSLIT("eqString") eqStringIdKey -- Base classes (Eq, Ord, Functor) -eqClassName = clsQual pREL_BASE_Name FSLIT("Eq") eqClassKey -functorClassName = clsQual pREL_BASE_Name FSLIT("Functor") functorClassKey -ordClassName = clsQual pREL_BASE_Name FSLIT("Ord") ordClassKey +eqClassName = clsQual pREL_BASE FSLIT("Eq") eqClassKey +eqName = methName eqClassName FSLIT("==") eqClassOpKey +ordClassName = clsQual pREL_BASE FSLIT("Ord") ordClassKey +geName = methName ordClassName FSLIT(">=") geClassOpKey +functorClassName = clsQual pREL_BASE FSLIT("Functor") functorClassKey -- Class Monad -monadClassName = clsQual pREL_BASE_Name FSLIT("Monad") monadClassKey -thenMName = varQual pREL_BASE_Name FSLIT(">>") thenMClassOpKey -bindMName = varQual pREL_BASE_Name FSLIT(">>=") bindMClassOpKey -returnMName = varQual pREL_BASE_Name FSLIT("return") returnMClassOpKey -failMName = varQual pREL_BASE_Name FSLIT("fail") failMClassOpKey - +monadClassName = clsQual pREL_BASE FSLIT("Monad") monadClassKey +thenMName = methName monadClassName FSLIT(">>") thenMClassOpKey +bindMName = methName monadClassName FSLIT(">>=") bindMClassOpKey +returnMName = methName monadClassName FSLIT("return") returnMClassOpKey +failMName = methName monadClassName FSLIT("fail") failMClassOpKey -- Random PrelBase functions -otherwiseIdName = varQual pREL_BASE_Name FSLIT("otherwise") otherwiseIdKey -foldrName = varQual pREL_BASE_Name FSLIT("foldr") foldrIdKey -buildName = varQual pREL_BASE_Name FSLIT("build") buildIdKey -augmentName = varQual pREL_BASE_Name FSLIT("augment") augmentIdKey -appendName = varQual pREL_BASE_Name FSLIT("++") appendIdKey -andName = varQual pREL_BASE_Name FSLIT("&&") andIdKey -orName = varQual pREL_BASE_Name FSLIT("||") orIdKey -assertName = varQual pREL_BASE_Name FSLIT("assert") assertIdKey -lazyIdName = wVarQual pREL_BASE_Name FSLIT("lazy") lazyIdKey +otherwiseIdName = varQual pREL_BASE FSLIT("otherwise") otherwiseIdKey +foldrName = varQual pREL_BASE FSLIT("foldr") foldrIdKey +buildName = varQual pREL_BASE FSLIT("build") buildIdKey +augmentName = varQual pREL_BASE FSLIT("augment") augmentIdKey +appendName = varQual pREL_BASE FSLIT("++") appendIdKey +andName = varQual pREL_BASE FSLIT("&&") andIdKey +orName = varQual pREL_BASE FSLIT("||") orIdKey +assertName = varQual pREL_BASE FSLIT("assert") assertIdKey -- PrelTup -fstName = varQual pREL_TUP_Name FSLIT("fst") fstIdKey -sndName = varQual pREL_TUP_Name FSLIT("snd") sndIdKey +fstName = varQual pREL_TUP FSLIT("fst") fstIdKey +sndName = varQual pREL_TUP FSLIT("snd") sndIdKey -- Module PrelNum -numClassName = clsQual pREL_NUM_Name FSLIT("Num") numClassKey -fromIntegerName = varQual pREL_NUM_Name FSLIT("fromInteger") fromIntegerClassOpKey -minusName = varQual pREL_NUM_Name FSLIT("-") minusClassOpKey -negateName = varQual pREL_NUM_Name FSLIT("negate") negateClassOpKey -plusIntegerName = varQual pREL_NUM_Name FSLIT("plusInteger") plusIntegerIdKey -timesIntegerName = varQual pREL_NUM_Name FSLIT("timesInteger") timesIntegerIdKey -integerTyConName = wTcQual pREL_NUM_Name FSLIT("Integer") integerTyConKey -smallIntegerDataConName = wDataQual pREL_NUM_Name FSLIT("S#") smallIntegerDataConKey -largeIntegerDataConName = wDataQual pREL_NUM_Name FSLIT("J#") largeIntegerDataConKey +numClassName = clsQual pREL_NUM FSLIT("Num") numClassKey +fromIntegerName = methName numClassName FSLIT("fromInteger") fromIntegerClassOpKey +minusName = methName numClassName FSLIT("-") minusClassOpKey +negateName = methName numClassName FSLIT("negate") negateClassOpKey +plusIntegerName = varQual pREL_NUM FSLIT("plusInteger") plusIntegerIdKey +timesIntegerName = varQual pREL_NUM FSLIT("timesInteger") timesIntegerIdKey +integerTyConName = tcQual pREL_NUM FSLIT("Integer") integerTyConKey +smallIntegerDataConName = conName integerTyConName FSLIT("S#") smallIntegerDataConKey +largeIntegerDataConName = conName integerTyConName FSLIT("J#") largeIntegerDataConKey -- PrelReal types and classes -rationalTyConName = tcQual pREL_REAL_Name FSLIT("Rational") rationalTyConKey -ratioTyConName = tcQual pREL_REAL_Name FSLIT("Ratio") ratioTyConKey -ratioDataConName = dataQual pREL_REAL_Name FSLIT(":%") ratioDataConKey -realClassName = clsQual pREL_REAL_Name FSLIT("Real") realClassKey -integralClassName = clsQual pREL_REAL_Name FSLIT("Integral") integralClassKey -realFracClassName = clsQual pREL_REAL_Name FSLIT("RealFrac") realFracClassKey -fractionalClassName = clsQual pREL_REAL_Name FSLIT("Fractional") fractionalClassKey -fromRationalName = varQual pREL_REAL_Name FSLIT("fromRational") fromRationalClassOpKey +rationalTyConName = tcQual pREL_REAL FSLIT("Rational") rationalTyConKey +ratioTyConName = tcQual pREL_REAL FSLIT("Ratio") ratioTyConKey +ratioDataConName = conName ratioTyConName FSLIT(":%") ratioDataConKey +realClassName = clsQual pREL_REAL FSLIT("Real") realClassKey +integralClassName = clsQual pREL_REAL FSLIT("Integral") integralClassKey +realFracClassName = clsQual pREL_REAL FSLIT("RealFrac") realFracClassKey +fractionalClassName = clsQual pREL_REAL FSLIT("Fractional") fractionalClassKey +fromRationalName = methName fractionalClassName FSLIT("fromRational") fromRationalClassOpKey -- PrelFloat classes -floatTyConName = wTcQual pREL_FLOAT_Name FSLIT("Float") floatTyConKey -floatDataConName = wDataQual pREL_FLOAT_Name FSLIT("F#") floatDataConKey -doubleTyConName = wTcQual pREL_FLOAT_Name FSLIT("Double") doubleTyConKey -doubleDataConName = wDataQual pREL_FLOAT_Name FSLIT("D#") doubleDataConKey -floatingClassName = clsQual pREL_FLOAT_Name FSLIT("Floating") floatingClassKey -realFloatClassName = clsQual pREL_FLOAT_Name FSLIT("RealFloat") realFloatClassKey +floatingClassName = clsQual pREL_FLOAT FSLIT("Floating") floatingClassKey +realFloatClassName = clsQual pREL_FLOAT FSLIT("RealFloat") realFloatClassKey -- Class Ix -ixClassName = clsQual pREL_ARR_Name FSLIT("Ix") ixClassKey +ixClassName = clsQual pREL_ARR FSLIT("Ix") ixClassKey -- Class Typeable and Data -typeableClassName = clsQual tYPEABLE_Name FSLIT("Typeable") typeableClassKey -dataClassName = clsQual gENERICS_Name FSLIT("Data") dataClassKey +typeableClassName = clsQual tYPEABLE FSLIT("Typeable") typeableClassKey +dataClassName = clsQual gENERICS FSLIT("Data") dataClassKey + +-- Error module +assertErrorName = varQual pREL_ERR FSLIT("assertError") assertErrorIdKey -- Enum module (Enum, Bounded) -enumClassName = clsQual pREL_ENUM_Name FSLIT("Enum") enumClassKey -enumFromName = varQual pREL_ENUM_Name FSLIT("enumFrom") enumFromClassOpKey -enumFromToName = varQual pREL_ENUM_Name FSLIT("enumFromTo") enumFromToClassOpKey -enumFromThenName = varQual pREL_ENUM_Name FSLIT("enumFromThen") enumFromThenClassOpKey -enumFromThenToName = varQual pREL_ENUM_Name FSLIT("enumFromThenTo") enumFromThenToClassOpKey -boundedClassName = clsQual pREL_ENUM_Name FSLIT("Bounded") boundedClassKey +enumClassName = clsQual pREL_ENUM FSLIT("Enum") enumClassKey +enumFromName = methName enumClassName FSLIT("enumFrom") enumFromClassOpKey +enumFromToName = methName enumClassName FSLIT("enumFromTo") enumFromToClassOpKey +enumFromThenName = methName enumClassName FSLIT("enumFromThen") enumFromThenClassOpKey +enumFromThenToName = methName enumClassName FSLIT("enumFromThenTo") enumFromThenToClassOpKey +boundedClassName = clsQual pREL_ENUM FSLIT("Bounded") boundedClassKey -- List functions -concatName = varQual pREL_LIST_Name FSLIT("concat") concatIdKey -filterName = varQual pREL_LIST_Name FSLIT("filter") filterIdKey -zipName = varQual pREL_LIST_Name FSLIT("zip") zipIdKey +concatName = varQual pREL_LIST FSLIT("concat") concatIdKey +filterName = varQual pREL_LIST FSLIT("filter") filterIdKey +zipName = varQual pREL_LIST FSLIT("zip") zipIdKey -- Class Show -showClassName = clsQual pREL_SHOW_Name FSLIT("Show") showClassKey +showClassName = clsQual pREL_SHOW FSLIT("Show") showClassKey -- Class Read -readClassName = clsQual pREL_READ_Name FSLIT("Read") readClassKey +readClassName = clsQual pREL_READ FSLIT("Read") readClassKey -- parallel array types and functions -enumFromToPName = varQual pREL_PARR_Name FSLIT("enumFromToP") enumFromToPIdKey -enumFromThenToPName= varQual pREL_PARR_Name FSLIT("enumFromThenToP") enumFromThenToPIdKey -parrTyConName = wTcQual pREL_PARR_Name FSLIT("[::]") parrTyConKey -parrDataConName = wDataQual pREL_PARR_Name FSLIT("PArr") parrDataConKey -nullPName = varQual pREL_PARR_Name FSLIT("nullP") nullPIdKey -lengthPName = varQual pREL_PARR_Name FSLIT("lengthP") lengthPIdKey -replicatePName = varQual pREL_PARR_Name FSLIT("replicateP") replicatePIdKey -mapPName = varQual pREL_PARR_Name FSLIT("mapP") mapPIdKey -filterPName = varQual pREL_PARR_Name FSLIT("filterP") filterPIdKey -zipPName = varQual pREL_PARR_Name FSLIT("zipP") zipPIdKey -crossPName = varQual pREL_PARR_Name FSLIT("crossP") crossPIdKey -indexPName = varQual pREL_PARR_Name FSLIT("!:") indexPIdKey -toPName = varQual pREL_PARR_Name FSLIT("toP") toPIdKey -bpermutePName = varQual pREL_PARR_Name FSLIT("bpermuteP") bpermutePIdKey -bpermuteDftPName = varQual pREL_PARR_Name FSLIT("bpermuteDftP") bpermuteDftPIdKey -indexOfPName = varQual pREL_PARR_Name FSLIT("indexOfP") indexOfPIdKey +enumFromToPName = varQual pREL_PARR FSLIT("enumFromToP") enumFromToPIdKey +enumFromThenToPName= varQual pREL_PARR FSLIT("enumFromThenToP") enumFromThenToPIdKey +nullPName = varQual pREL_PARR FSLIT("nullP") nullPIdKey +lengthPName = varQual pREL_PARR FSLIT("lengthP") lengthPIdKey +replicatePName = varQual pREL_PARR FSLIT("replicateP") replicatePIdKey +mapPName = varQual pREL_PARR FSLIT("mapP") mapPIdKey +filterPName = varQual pREL_PARR FSLIT("filterP") filterPIdKey +zipPName = varQual pREL_PARR FSLIT("zipP") zipPIdKey +crossPName = varQual pREL_PARR FSLIT("crossP") crossPIdKey +indexPName = varQual pREL_PARR FSLIT("!:") indexPIdKey +toPName = varQual pREL_PARR FSLIT("toP") toPIdKey +bpermutePName = varQual pREL_PARR FSLIT("bpermuteP") bpermutePIdKey +bpermuteDftPName = varQual pREL_PARR FSLIT("bpermuteDftP") bpermuteDftPIdKey +indexOfPName = varQual pREL_PARR FSLIT("indexOfP") indexOfPIdKey -- IOBase things -ioTyConName = tcQual pREL_IO_BASE_Name FSLIT("IO") ioTyConKey -ioDataConName = dataQual pREL_IO_BASE_Name FSLIT("IO") ioDataConKey -thenIOName = varQual pREL_IO_BASE_Name FSLIT("thenIO") thenIOIdKey -bindIOName = varQual pREL_IO_BASE_Name FSLIT("bindIO") bindIOIdKey -returnIOName = varQual pREL_IO_BASE_Name FSLIT("returnIO") returnIOIdKey -failIOName = varQual pREL_IO_BASE_Name FSLIT("failIO") failIOIdKey +ioTyConName = tcQual pREL_IO_BASE FSLIT("IO") ioTyConKey +ioDataConName = conName ioTyConName FSLIT("IO") ioDataConKey +thenIOName = varQual pREL_IO_BASE FSLIT("thenIO") thenIOIdKey +bindIOName = varQual pREL_IO_BASE FSLIT("bindIO") bindIOIdKey +returnIOName = varQual pREL_IO_BASE FSLIT("returnIO") returnIOIdKey +failIOName = varQual pREL_IO_BASE FSLIT("failIO") failIOIdKey -- IO things -printName = varQual sYSTEM_IO_Name FSLIT("print") printIdKey +printName = varQual sYSTEM_IO FSLIT("print") printIdKey -- Int, Word, and Addr things -int8TyConName = tcQual pREL_INT_Name FSLIT("Int8") int8TyConKey -int16TyConName = tcQual pREL_INT_Name FSLIT("Int16") int16TyConKey -int32TyConName = tcQual pREL_INT_Name FSLIT("Int32") int32TyConKey -int64TyConName = tcQual pREL_INT_Name FSLIT("Int64") int64TyConKey +int8TyConName = tcQual pREL_INT FSLIT("Int8") int8TyConKey +int16TyConName = tcQual pREL_INT FSLIT("Int16") int16TyConKey +int32TyConName = tcQual pREL_INT FSLIT("Int32") int32TyConKey +int64TyConName = tcQual pREL_INT FSLIT("Int64") int64TyConKey -- Word module -word8TyConName = tcQual pREL_WORD_Name FSLIT("Word8") word8TyConKey -word16TyConName = tcQual pREL_WORD_Name FSLIT("Word16") word16TyConKey -word32TyConName = tcQual pREL_WORD_Name FSLIT("Word32") word32TyConKey -word64TyConName = tcQual pREL_WORD_Name FSLIT("Word64") word64TyConKey -wordTyConName = wTcQual pREL_WORD_Name FSLIT("Word") wordTyConKey -wordDataConName = wDataQual pREL_WORD_Name FSLIT("W#") wordDataConKey +word8TyConName = tcQual pREL_WORD FSLIT("Word8") word8TyConKey +word16TyConName = tcQual pREL_WORD FSLIT("Word16") word16TyConKey +word32TyConName = tcQual pREL_WORD FSLIT("Word32") word32TyConKey +word64TyConName = tcQual pREL_WORD FSLIT("Word64") word64TyConKey +wordTyConName = tcQual pREL_WORD FSLIT("Word") wordTyConKey +wordDataConName = conName wordTyConName FSLIT("W#") wordDataConKey -- Addr module -addrTyConName = tcQual aDDR_Name FSLIT("Addr") addrTyConKey +addrTyConName = tcQual aDDR FSLIT("Addr") addrTyConKey -- PrelPtr module -ptrTyConName = tcQual pREL_PTR_Name FSLIT("Ptr") ptrTyConKey -funPtrTyConName = tcQual pREL_PTR_Name FSLIT("FunPtr") funPtrTyConKey +ptrTyConName = tcQual pREL_PTR FSLIT("Ptr") ptrTyConKey +funPtrTyConName = tcQual pREL_PTR FSLIT("FunPtr") funPtrTyConKey -- Byte array types -byteArrayTyConName = tcQual pREL_BYTEARR_Name FSLIT("ByteArray") byteArrayTyConKey -mutableByteArrayTyConName = tcQual pREL_BYTEARR_Name FSLIT("MutableByteArray") mutableByteArrayTyConKey +byteArrayTyConName = tcQual pREL_BYTEARR FSLIT("ByteArray") byteArrayTyConKey +mutableByteArrayTyConName = tcQual pREL_BYTEARR FSLIT("MutableByteArray") mutableByteArrayTyConKey -- Foreign objects and weak pointers -stablePtrTyConName = tcQual pREL_STABLE_Name FSLIT("StablePtr") stablePtrTyConKey -newStablePtrName = varQual pREL_STABLE_Name FSLIT("newStablePtr") newStablePtrIdKey - --- Error module -errorName = wVarQual pREL_ERR_Name FSLIT("error") errorIdKey -assertErrorName = wVarQual pREL_ERR_Name FSLIT("assertError") assertErrorIdKey -recSelErrorName = wVarQual pREL_ERR_Name FSLIT("recSelError") recSelErrorIdKey -runtimeErrorName = wVarQual pREL_ERR_Name FSLIT("runtimeError") runtimeErrorIdKey -irrefutPatErrorName = wVarQual pREL_ERR_Name FSLIT("irrefutPatError") irrefutPatErrorIdKey -recConErrorName = wVarQual pREL_ERR_Name FSLIT("recConError") recConErrorIdKey -patErrorName = wVarQual pREL_ERR_Name FSLIT("patError") patErrorIdKey -noMethodBindingErrorName = wVarQual pREL_ERR_Name FSLIT("noMethodBindingError") noMethodBindingErrorIdKey -nonExhaustiveGuardsErrorName - = wVarQual pREL_ERR_Name FSLIT("nonExhaustiveGuardsError") nonExhaustiveGuardsErrorIdKey +stablePtrTyConName = tcQual pREL_STABLE FSLIT("StablePtr") stablePtrTyConKey +newStablePtrName = varQual pREL_STABLE FSLIT("newStablePtr") newStablePtrIdKey -- PrelST module -runSTRepName = varQual pREL_ST_Name FSLIT("runSTRep") runSTRepIdKey +runSTRepName = varQual pREL_ST FSLIT("runSTRep") runSTRepIdKey -- The "split" Id for splittable implicit parameters -splitName = varQual gLA_EXTS_Name FSLIT("split") splitIdKey +splitName = varQual gLA_EXTS FSLIT("split") splitIdKey -- Recursive-do notation -mfixName = varQual mONAD_FIX_Name FSLIT("mfix") mfixIdKey +mfixName = varQual mONAD_FIX FSLIT("mfix") mfixIdKey -- Arrow notation -arrAName = varQual aRROW_Name FSLIT("arr") arrAIdKey -composeAName = varQual aRROW_Name FSLIT(">>>") composeAIdKey -firstAName = varQual aRROW_Name FSLIT("first") firstAIdKey -appAName = varQual aRROW_Name FSLIT("app") appAIdKey -choiceAName = varQual aRROW_Name FSLIT("|||") choiceAIdKey -loopAName = varQual aRROW_Name FSLIT("loop") loopAIdKey +arrAName = varQual aRROW FSLIT("arr") arrAIdKey +composeAName = varQual aRROW FSLIT(">>>") composeAIdKey +firstAName = varQual aRROW FSLIT("first") firstAIdKey +appAName = varQual aRROW FSLIT("app") appAIdKey +choiceAName = varQual aRROW FSLIT("|||") choiceAIdKey +loopAName = varQual aRROW FSLIT("loop") loopAIdKey -- dotnet interop -objectTyConName = wTcQual dOTNET_Name FSLIT("Object") objectTyConKey -unmarshalObjectName = varQual dOTNET_Name FSLIT("unmarshalObject") unmarshalObjectIdKey -marshalObjectName = varQual dOTNET_Name FSLIT("marshalObject") marshalObjectIdKey -marshalStringName = varQual dOTNET_Name FSLIT("marshalString") marshalStringIdKey -unmarshalStringName = varQual dOTNET_Name FSLIT("unmarshalString") unmarshalStringIdKey -checkDotnetResName = varQual dOTNET_Name FSLIT("checkResult") checkDotnetResNameIdKey - +objectTyConName = tcQual dOTNET FSLIT("Object") objectTyConKey + -- objectTyConName was "wTcQual", but that's gone now, and + -- I can't see why it was wired in anyway... +unmarshalObjectName = varQual dOTNET FSLIT("unmarshalObject") unmarshalObjectIdKey +marshalObjectName = varQual dOTNET FSLIT("marshalObject") marshalObjectIdKey +marshalStringName = varQual dOTNET FSLIT("marshalString") marshalStringIdKey +unmarshalStringName = varQual dOTNET FSLIT("unmarshalString") unmarshalStringIdKey +checkDotnetResName = varQual dOTNET FSLIT("checkResult") checkDotnetResNameIdKey \end{code} %************************************************************************ @@ -732,29 +677,22 @@ All these are original names; hence mkOrig \begin{code} varQual = mk_known_key_name varName -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 -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) -- 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) - mk_known_key_name space mod str uniq - = mkKnownKeyExternalName (mkBasePkgModule mod) (mkOccFS space str) uniq -mk_wired_in_name space mod str uniq - = mkWiredInName (mkBasePkgModule mod) (mkOccFS space str) uniq - -kindQual str uq = mkInternalName uq (mkKindOccFS tcName str) noSrcLoc - -- Kinds are not z-encoded in interface file, hence mkKindOccFS - -- And they don't come from any particular module; indeed we always - -- want to print them unqualified. Hence the LocalName + = mkExternalName uniq mod (mkOccFS space str) + Nothing noSrcLoc + +conName :: Name -> FastString -> Unique -> Name +conName tycon occ uniq + = mkExternalName uniq (nameModule tycon) (mkOccFS dataName occ) + (Just tycon) noSrcLoc + +methName :: Name -> FastString -> Unique -> Name +methName cls occ uniq + = mkExternalName uniq (nameModule cls) (mkOccFS varName occ) + (Just cls) noSrcLoc \end{code} %************************************************************************ diff --git a/ghc/compiler/prelude/PrimOp.lhs b/ghc/compiler/prelude/PrimOp.lhs index 94d42a074c..a9ac056139 100644 --- a/ghc/compiler/prelude/PrimOp.lhs +++ b/ghc/compiler/prelude/PrimOp.lhs @@ -7,7 +7,7 @@ module PrimOp ( PrimOp(..), allThePrimOps, primOpType, primOpSig, primOpArity, - mkPrimOpIdName, primOpTag, primOpOcc, + primOpTag, maxPrimOpTag, primOpOcc, commutableOp, @@ -15,12 +15,7 @@ module PrimOp ( primOpOkForSpeculation, primOpIsCheap, primOpIsDupable, primOpHasSideEffects, - getPrimOpResultInfo, PrimOpResultInfo(..), - - eqCharName, eqIntName, neqIntName, - ltCharName, eqWordName, ltWordName, eqAddrName, ltAddrName, - eqFloatName, ltFloatName, eqDoubleName, ltDoubleName, - ltIntName, geIntName, leIntName, minusIntName, tagToEnumName + getPrimOpResultInfo, PrimOpResultInfo(..) ) where #include "HsVersions.h" @@ -31,14 +26,10 @@ import TysWiredIn import NewDemand import Var ( TyVar ) -import Name ( Name, mkWiredInName ) import OccName ( OccName, pprOccName, mkVarOcc ) import TyCon ( TyCon, isPrimTyCon, tyConPrimRep ) import Type ( Type, mkForAllTys, mkFunTy, mkFunTys, typePrimRep, tyConAppTyCon ) -import PprType () -- get at Outputable Type instance. -import Unique ( mkPrimOpIdUnique ) import BasicTypes ( Arity, Boxity(..) ) -import PrelNames ( gHC_PRIM ) import Outputable import FastTypes \end{code} @@ -90,6 +81,7 @@ instance Show PrimOp where \end{code} An @Enum@-derived list would be better; meanwhile... (ToDo) + \begin{code} allThePrimOps :: [PrimOp] allThePrimOps = @@ -394,19 +386,12 @@ primOpType op GenPrimOp occ tyvars arg_tys res_ty -> mkForAllTys tyvars (mkFunTys arg_tys res_ty) -mkPrimOpIdName :: PrimOp -> Name - -- Make the name for the PrimOp's Id - -- We have to pass in the Id itself because it's a WiredInId - -- and hence recursive -mkPrimOpIdName op - = mkWiredInName gHC_PRIM (primOpOcc op) (mkPrimOpIdUnique (primOpTag op)) - primOpOcc :: PrimOp -> OccName primOpOcc op = case (primOpInfo op) of - Dyadic occ _ -> occ - Monadic occ _ -> occ - Compare occ _ -> occ - GenPrimOp occ _ _ _ -> occ + Dyadic occ _ -> occ + Monadic occ _ -> occ + Compare occ _ -> occ + GenPrimOp occ _ _ _ -> occ -- primOpSig is like primOpType but gives the result split apart: -- (type variables, argument types, result type) @@ -471,35 +456,3 @@ pprPrimOp :: PrimOp -> SDoc pprPrimOp other_op = pprOccName (primOpOcc other_op) \end{code} - -%************************************************************************ -%* * - Names for some primops (for ndpFlatten/FlattenMonad.lhs) -%* * -%************************************************************************ - -\begin{code} -eqIntName = mkPrimOpIdName IntEqOp -ltIntName = mkPrimOpIdName IntLtOp -geIntName = mkPrimOpIdName IntGeOp -leIntName = mkPrimOpIdName IntLeOp -neqIntName = mkPrimOpIdName IntNeOp -minusIntName = mkPrimOpIdName IntSubOp - -eqCharName = mkPrimOpIdName CharEqOp -ltCharName = mkPrimOpIdName CharLtOp - -eqFloatName = mkPrimOpIdName FloatEqOp -ltFloatName = mkPrimOpIdName FloatLtOp - -eqDoubleName = mkPrimOpIdName DoubleEqOp -ltDoubleName = mkPrimOpIdName DoubleLtOp - -eqWordName = mkPrimOpIdName WordEqOp -ltWordName = mkPrimOpIdName WordLtOp - -eqAddrName = mkPrimOpIdName AddrEqOp -ltAddrName = mkPrimOpIdName AddrLtOp - -tagToEnumName = mkPrimOpIdName TagToEnumOp -\end{code} diff --git a/ghc/compiler/prelude/TysPrim.lhs b/ghc/compiler/prelude/TysPrim.lhs index 9ba2887375..fab63e5011 100644 --- a/ghc/compiler/prelude/TysPrim.lhs +++ b/ghc/compiler/prelude/TysPrim.lhs @@ -45,18 +45,19 @@ module TysPrim( #include "HsVersions.h" import Var ( TyVar, mkTyVar ) -import Name ( Name, mkInternalName ) -import OccName ( mkVarOcc ) +import Name ( Name, mkInternalName, mkWiredInName ) +import OccName ( mkVarOcc, mkOccFS, tcName ) import PrimRep ( PrimRep(..) ) import TyCon ( TyCon, ArgVrcs, mkPrimTyCon, mkLiftedPrimTyCon ) import Type ( mkTyConApp, mkTyConTy, mkTyVarTys, mkTyVarTy, unliftedTypeKind, liftedTypeKind, openTypeKind, - Kind, mkArrowKinds + Kind, mkArrowKinds, + TyThing(..) ) import SrcLoc ( noSrcLoc ) import Unique ( mkAlphaTyVarUnique ) import PrelNames -import FastString ( mkFastString ) +import FastString ( FastString, mkFastString ) import Outputable import Char ( ord, chr ) @@ -96,8 +97,39 @@ primTyCons , word32PrimTyCon , word64PrimTyCon ] -\end{code} +mkPrimTc :: FastString -> Unique -> TyCon -> Name +mkPrimTc fs uniq tycon + = mkWiredInName gHC_PRIM (mkOccFS tcName fs) + uniq + Nothing -- No parent object + (ATyCon tycon) -- Relevant TyCon + +charPrimTyConName = mkPrimTc FSLIT("Char#") charPrimTyConKey charPrimTyCon +intPrimTyConName = mkPrimTc FSLIT("Int#") intPrimTyConKey intPrimTyCon +int32PrimTyConName = mkPrimTc FSLIT("Int32#") int32PrimTyConKey int32PrimTyCon +int64PrimTyConName = mkPrimTc FSLIT("Int64#") int64PrimTyConKey int64PrimTyCon +wordPrimTyConName = mkPrimTc FSLIT("Word#") wordPrimTyConKey wordPrimTyCon +word32PrimTyConName = mkPrimTc FSLIT("Word32#") word32PrimTyConKey word32PrimTyCon +word64PrimTyConName = mkPrimTc FSLIT("Word64#") word64PrimTyConKey word64PrimTyCon +addrPrimTyConName = mkPrimTc FSLIT("Addr#") addrPrimTyConKey addrPrimTyCon +floatPrimTyConName = mkPrimTc FSLIT("Float#") floatPrimTyConKey floatPrimTyCon +doublePrimTyConName = mkPrimTc FSLIT("Double#") doublePrimTyConKey doublePrimTyCon +statePrimTyConName = mkPrimTc FSLIT("State#") statePrimTyConKey statePrimTyCon +realWorldTyConName = mkPrimTc FSLIT("RealWorld") realWorldTyConKey realWorldTyCon +arrayPrimTyConName = mkPrimTc FSLIT("Array#") arrayPrimTyConKey arrayPrimTyCon +byteArrayPrimTyConName = mkPrimTc FSLIT("ByteArray#") byteArrayPrimTyConKey byteArrayPrimTyCon +mutableArrayPrimTyConName = mkPrimTc FSLIT("MutableArray#") mutableArrayPrimTyConKey mutableArrayPrimTyCon +mutableByteArrayPrimTyConName = mkPrimTc FSLIT("MutableByteArray#") mutableByteArrayPrimTyConKey mutableByteArrayPrimTyCon +mutVarPrimTyConName = mkPrimTc FSLIT("MutVar#") mutVarPrimTyConKey mutVarPrimTyCon +mVarPrimTyConName = mkPrimTc FSLIT("MVar#") mVarPrimTyConKey mVarPrimTyCon +stablePtrPrimTyConName = mkPrimTc FSLIT("StablePtr#") stablePtrPrimTyConKey stablePtrPrimTyCon +stableNamePrimTyConName = mkPrimTc FSLIT("StableName#") stableNamePrimTyConKey stableNamePrimTyCon +foreignObjPrimTyConName = mkPrimTc FSLIT("ForeignObj#") foreignObjPrimTyConKey foreignObjPrimTyCon +bcoPrimTyConName = mkPrimTc FSLIT("BCO#") bcoPrimTyConKey bcoPrimTyCon +weakPrimTyConName = mkPrimTc FSLIT("Weak#") weakPrimTyConKey weakPrimTyCon +threadIdPrimTyConName = mkPrimTc FSLIT("ThreadId#") threadIdPrimTyConKey threadIdPrimTyCon +\end{code} %************************************************************************ %* * diff --git a/ghc/compiler/prelude/TysWiredIn.lhs b/ghc/compiler/prelude/TysWiredIn.lhs index 2975922af8..4d8de984e3 100644 --- a/ghc/compiler/prelude/TysWiredIn.lhs +++ b/ghc/compiler/prelude/TysWiredIn.lhs @@ -11,35 +11,26 @@ types and operations.'' \begin{code} module TysWiredIn ( - wiredInTyCons, genericTyCons, - - boolTy, - boolTyCon, - charDataCon, - charTy, - charTyCon, - consDataCon, - doubleDataCon, - doubleTy, - doubleTyCon, - falseDataCon, falseDataConId, - floatDataCon, - floatTy, - floatTyCon, - - intDataCon, - intTy, - intTyCon, + wiredInTyCons, + + boolTy, boolTyCon, boolTyCon_RDR, boolTyConName, + trueDataCon, trueDataConId, true_RDR, + falseDataCon, falseDataConId, false_RDR, + + charTyCon, charDataCon, charTyCon_RDR, + charTy, stringTy, charTyConName, - integerTy, - integerTyCon, - smallIntegerDataCon, - largeIntegerDataCon, + + doubleTyCon, doubleDataCon, doubleTy, + + floatTyCon, floatDataCon, floatTy, - listTyCon, + intTyCon, intDataCon, intTyCon_RDR, intDataCon_RDR, intTyConName, + intTy, + listTyCon, nilDataCon, consDataCon, + listTyCon_RDR, consDataCon_RDR, listTyConName, mkListTy, - nilDataCon, -- tuples mkTupleTy, @@ -48,28 +39,18 @@ module TysWiredIn ( unboxedSingletonTyCon, unboxedSingletonDataCon, unboxedPairTyCon, unboxedPairDataCon, - -- Generics - genUnitTyCon, genUnitDataCon, - plusTyCon, inrDataCon, inlDataCon, - crossTyCon, crossDataCon, - - stringTy, - trueDataCon, trueDataConId, unitTy, voidTy, - wordDataCon, - wordTy, - wordTyCon, -- parallel arrays mkPArrTy, - parrTyCon, parrFakeCon, isPArrTyCon, isPArrFakeCon + parrTyCon, parrFakeCon, isPArrTyCon, isPArrFakeCon, + parrTyCon_RDR, parrTyConName ) where #include "HsVersions.h" -import {-# SOURCE #-} MkId( mkDataConWorkId ) -import {-# SOURCE #-} Generics( mkTyConGenInfo ) +import {-# SOURCE #-} MkId( mkDataConIds ) -- friends: import PrelNames @@ -77,30 +58,31 @@ import TysPrim -- others: import Constants ( mAX_TUPLE_SIZE ) -import Module ( mkBasePkgModule ) +import Module ( Module ) +import RdrName ( nameRdrName ) import Name ( Name, nameUnique, nameOccName, nameModule, mkWiredInName ) -import OccName ( mkOccFS, tcName, dataName, mkDataConWorkerOcc, mkGenOcc1, mkGenOcc2 ) +import OccName ( mkOccFS, tcName, dataName, mkTupleOcc, mkDataConWorkerOcc ) import DataCon ( DataCon, mkDataCon, dataConWorkId, dataConSourceArity ) import Var ( TyVar, tyVarKind ) import TyCon ( TyCon, AlgTyConFlavour(..), DataConDetails(..), tyConDataCons, mkTupleTyCon, mkAlgTyCon, tyConName ) -import BasicTypes ( Arity, RecFlag(..), Boxity(..), isBoxed ) +import BasicTypes ( Arity, RecFlag(..), Boxity(..), isBoxed, StrictnessMark(..) ) import Type ( Type, mkTyConTy, mkTyConApp, mkTyVarTy, mkTyVarTys, mkArrowKinds, liftedTypeKind, unliftedTypeKind, - ThetaType ) + ThetaType, TyThing(..) ) import Unique ( incrUnique, mkTupleTyConUnique, mkTupleDataConUnique, mkPArrDataConUnique ) import PrelNames import Array import FastString +import Outputable -alpha_tyvar = [alphaTyVar] -alpha_ty = [alphaTy] -alpha_beta_tyvars = [alphaTyVar, betaTyVar] +alpha_tyvar = [alphaTyVar] +alpha_ty = [alphaTy] \end{code} @@ -114,26 +96,65 @@ If you change which things are wired in, make sure you change their names in PrelNames, so they use wTcQual, wDataQual, etc \begin{code} -wiredInTyCons :: [TyCon] -wiredInTyCons = data_tycons ++ tuple_tycons ++ unboxed_tuple_tycons - -data_tycons = genericTyCons ++ - [ boolTyCon +wiredInTyCons :: [TyCon] -- Excludes tuples +wiredInTyCons = [ unitTyCon -- Not treated like other tuples, because + -- it's defined in GHC.Base, and there's only + -- one of it. We put it in wiredInTyCons so + -- that it'll pre-populate the name cache, so + -- the special case in lookupOrigNameCache + -- doesn't need to look out for it + , boolTyCon , charTyCon , doubleTyCon , floatTyCon , intTyCon - , integerTyCon , listTyCon , parrTyCon - , wordTyCon ] +\end{code} -genericTyCons :: [TyCon] -genericTyCons = [ plusTyCon, crossTyCon, genUnitTyCon ] - -tuple_tycons = unitTyCon : [tupleTyCon Boxed i | i <- [2..mAX_TUPLE_SIZE] ] -unboxed_tuple_tycons = [tupleTyCon Unboxed i | i <- [1..mAX_TUPLE_SIZE] ] +\begin{code} +mkWiredInTyConName :: Module -> FastString -> Unique -> TyCon -> Name +mkWiredInTyConName mod fs uniq tycon + = mkWiredInName mod (mkOccFS tcName fs) uniq + Nothing -- No parent object + (ATyCon tycon) -- Relevant TyCon + +mkWiredInDataConName :: Module -> FastString -> Unique -> DataCon -> Name -> Name +mkWiredInDataConName mod fs uniq datacon parent + = mkWiredInName mod (mkOccFS dataName fs) uniq + (Just parent) -- Name of parent TyCon + (ADataCon datacon) -- Relevant DataCon + +charTyConName = mkWiredInTyConName pREL_BASE FSLIT("Char") charTyConKey charTyCon +charDataConName = mkWiredInDataConName pREL_BASE FSLIT("C#") charDataConKey charDataCon charTyConName +intTyConName = mkWiredInTyConName pREL_BASE FSLIT("Int") intTyConKey intTyCon +intDataConName = mkWiredInDataConName pREL_BASE FSLIT("I#") intDataConKey intDataCon intTyConName + +boolTyConName = mkWiredInTyConName pREL_BASE FSLIT("Bool") boolTyConKey boolTyCon +falseDataConName = mkWiredInDataConName pREL_BASE FSLIT("False") falseDataConKey falseDataCon boolTyConName +trueDataConName = mkWiredInDataConName pREL_BASE FSLIT("True") trueDataConKey trueDataCon boolTyConName +listTyConName = mkWiredInTyConName pREL_BASE FSLIT("[]") listTyConKey listTyCon +nilDataConName = mkWiredInDataConName pREL_BASE FSLIT("[]") nilDataConKey nilDataCon listTyConName +consDataConName = mkWiredInDataConName pREL_BASE FSLIT(":") consDataConKey consDataCon listTyConName + +floatTyConName = mkWiredInTyConName pREL_FLOAT FSLIT("Float") floatTyConKey floatTyCon +floatDataConName = mkWiredInDataConName pREL_FLOAT FSLIT("F#") floatDataConKey floatDataCon floatTyConName +doubleTyConName = mkWiredInTyConName pREL_FLOAT FSLIT("Double") doubleTyConKey doubleTyCon +doubleDataConName = mkWiredInDataConName pREL_FLOAT FSLIT("D#") doubleDataConKey doubleDataCon doubleTyConName + +parrTyConName = mkWiredInTyConName pREL_PARR FSLIT("[::]") parrTyConKey parrTyCon +parrDataConName = mkWiredInDataConName pREL_PARR FSLIT("PArr") parrDataConKey parrDataCon parrTyConName + +boolTyCon_RDR = nameRdrName boolTyConName +false_RDR = nameRdrName falseDataConName +true_RDR = nameRdrName trueDataConName +intTyCon_RDR = nameRdrName intTyConName +charTyCon_RDR = nameRdrName charTyConName +intDataCon_RDR = nameRdrName intDataConName +listTyCon_RDR = nameRdrName listTyConName +consDataCon_RDR = nameRdrName consDataConName +parrTyCon_RDR = nameRdrName parrTyConName \end{code} @@ -144,39 +165,22 @@ unboxed_tuple_tycons = [tupleTyCon Unboxed i | i <- [1..mAX_TUPLE_SIZE] ] %************************************************************************ \begin{code} -pcNonRecDataTyCon = pcTyCon DataTyCon NonRecursive -pcRecDataTyCon = pcTyCon DataTyCon Recursive +pcNonRecDataTyCon = pcTyCon False NonRecursive +pcRecDataTyCon = pcTyCon False Recursive -pcTyCon new_or_data is_rec name tyvars argvrcs cons +pcTyCon is_enum is_rec name tyvars argvrcs cons = tycon where - tycon = mkAlgTyCon name kind + tycon = mkAlgTyCon name + (mkArrowKinds (map tyVarKind tyvars) liftedTypeKind) tyvars [] -- No context argvrcs (DataCons cons) [] -- No record selectors - new_or_data + (DataTyCon is_enum) is_rec - gen_info - - mod = nameModule name - kind = mkArrowKinds (map tyVarKind tyvars) liftedTypeKind - gen_info = mk_tc_gen_info mod (nameUnique name) name tycon - --- We generate names for the generic to/from Ids by incrementing --- the TyCon unique. So each Prelude tycon needs 3 slots, one --- for itself and two more for the generic Ids. -mk_tc_gen_info mod tc_uniq tc_name tycon - = mkTyConGenInfo tycon [name1, name2] - where - tc_occ_name = nameOccName tc_name - occ_name1 = mkGenOcc1 tc_occ_name - occ_name2 = mkGenOcc2 tc_occ_name - fn1_key = incrUnique tc_uniq - fn2_key = incrUnique fn1_key - name1 = mkWiredInName mod occ_name1 fn1_key - name2 = mkWiredInName mod occ_name2 fn2_key + True -- All the wired-in tycons have generics pcDataCon :: Name -> [TyVar] -> ThetaType -> [Type] -> TyCon -> DataCon -- The Name should be in the DataName name space; it's the name @@ -190,17 +194,19 @@ pcDataCon dc_name tyvars context arg_tys tycon = data_con where data_con = mkDataCon dc_name - [{- No strictness -}] + (map (const NotMarkedStrict) arg_tys) [{- No labelled fields -}] - tyvars context [] [] arg_tys tycon work_id - Nothing {- No wrapper for wired-in things - (they are too simple to need one) -} + tyvars context [] [] arg_tys tycon + (mkDataConIds bogus_wrap_name wrk_name data_con) 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 + (Just (tyConName tycon)) + (AnId (dataConWorkId data_con)) + bogus_wrap_name = pprPanic "Wired-in data wrapper id" (ppr dc_name) + -- Wired-in types are too simple to need wrappers \end{code} @@ -229,7 +235,9 @@ mk_tuple :: Boxity -> Int -> (TyCon,DataCon) mk_tuple boxity arity = (tycon, tuple_con) where tycon = mkTupleTyCon tc_name tc_kind arity tyvars tuple_con boxity gen_info - tc_name = mkWiredInName mod (mkOccFS tcName name_str) tc_uniq + mod = mkTupleModule boxity arity + tc_name = mkWiredInName mod (mkTupleOcc tcName boxity arity) tc_uniq + Nothing (ATyCon tycon) tc_kind = mkArrowKinds (map tyVarKind tyvars) res_kind res_kind | isBoxed boxity = liftedTypeKind | otherwise = unliftedTypeKind @@ -237,14 +245,14 @@ mk_tuple boxity arity = (tycon, tuple_con) tyvars | isBoxed boxity = take arity alphaTyVars | otherwise = take arity openAlphaTyVars - tuple_con = pcDataCon name tyvars [] tyvar_tys tycon + tuple_con = pcDataCon dc_name tyvars [] tyvar_tys tycon tyvar_tys = mkTyVarTys tyvars - (mod_name, name_str) = mkTupNameStr boxity arity - name = mkWiredInName mod (mkOccFS dataName name_str) dc_uniq + dc_name = mkWiredInName mod (mkTupleOcc dataName boxity arity) dc_uniq + (Just tc_name) (ADataCon tuple_con) tc_uniq = mkTupleTyConUnique boxity arity dc_uniq = mkTupleDataConUnique boxity arity - mod = mkBasePkgModule mod_name - gen_info = mk_tc_gen_info mod tc_uniq tc_name tycon + gen_info = True -- Tuples all have generics.. + -- hmm: that's a *lot* of code unitTyCon = tupleTyCon Boxed 0 unitDataCon = head (tyConDataCons unitTyCon) @@ -298,13 +306,6 @@ intDataCon = pcDataCon intDataConName [] [] [intPrimTy] intTyCon \end{code} \begin{code} -wordTy = mkTyConTy wordTyCon - -wordTyCon = pcNonRecDataTyCon wordTyConName [] [] [wordDataCon] -wordDataCon = pcDataCon wordDataConName [] [] [wordPrimTy] wordTyCon -\end{code} - -\begin{code} floatTy = mkTyConTy floatTyCon floatTyCon = pcNonRecDataTyCon floatTyConName [] [] [floatDataCon] @@ -321,27 +322,6 @@ doubleDataCon = pcDataCon doubleDataConName [] [] [doublePrimTy] doubleTyCon %************************************************************************ %* * -\subsection[TysWiredIn-Integer]{@Integer@ and its related ``pairing'' types} -%* * -%************************************************************************ - -@Integer@ and its pals are not really primitive. @Integer@ itself, first: -\begin{code} -integerTy :: Type -integerTy = mkTyConTy integerTyCon - -integerTyCon = pcNonRecDataTyCon integerTyConName - [] [] [smallIntegerDataCon, largeIntegerDataCon] - -smallIntegerDataCon = pcDataCon smallIntegerDataConName - [] [] [intPrimTy] integerTyCon -largeIntegerDataCon = pcDataCon largeIntegerDataConName - [] [] [intPrimTy, byteArrayPrimTy] integerTyCon -\end{code} - - -%************************************************************************ -%* * \subsection[TysWiredIn-Bool]{The @Bool@ type} %* * %************************************************************************ @@ -391,7 +371,7 @@ primitive counterpart. \begin{code} boolTy = mkTyConTy boolTyCon -boolTyCon = pcTyCon EnumTyCon NonRecursive boolTyConName +boolTyCon = pcTyCon True NonRecursive boolTyConName [] [] [falseDataCon, trueDataCon] falseDataCon = pcDataCon falseDataConName [] [] [] boolTyCon @@ -508,23 +488,7 @@ mkPArrTy ty = mkTyConApp parrTyCon [ty] -- `PrelPArr'. -- parrTyCon :: TyCon -parrTyCon = tycon - where - tycon = mkAlgTyCon - parrTyConName - kind - tyvars - [] -- No context - [(True, False)] - (DataCons [parrDataCon]) -- The constructor defined in `PrelPArr' - [] -- No record selectors - DataTyCon - NonRecursive - genInfo - tyvars = alpha_tyvar - mod = nameModule parrTyConName - kind = mkArrowKinds (map tyVarKind tyvars) liftedTypeKind - genInfo = mk_tc_gen_info mod (nameUnique parrTyConName) parrTyConName tycon +parrTyCon = pcNonRecDataTyCon parrTyConName alpha_tyvar [(True, False)] [parrDataCon] parrDataCon :: DataCon parrDataCon = pcDataCon @@ -562,14 +526,15 @@ parrFakeConArr = array (0, mAX_TUPLE_SIZE) [(i, mkPArrFakeCon i) -- build a fake parallel array constructor for the given arity -- mkPArrFakeCon :: Int -> DataCon -mkPArrFakeCon arity = pcDataCon name [tyvar] [] tyvarTys parrTyCon +mkPArrFakeCon arity = data_con where + data_con = pcDataCon name [tyvar] [] tyvarTys parrTyCon tyvar = head alphaTyVars tyvarTys = replicate arity $ mkTyVarTy tyvar nameStr = mkFastString ("MkPArr" ++ show arity) - name = mkWiredInName mod (mkOccFS dataName nameStr) uniq + name = mkWiredInName pREL_PARR (mkOccFS dataName nameStr) uniq + Nothing (ADataCon data_con) uniq = mkPArrDataConUnique arity - mod = mkBasePkgModule pREL_PARR_Name -- checks whether a data constructor is a fake constructor for parallel arrays -- @@ -577,37 +542,3 @@ isPArrFakeCon :: DataCon -> Bool isPArrFakeCon dcon = dcon == parrFakeCon (dataConSourceArity dcon) \end{code} -%************************************************************************ -%* * -\subsection{Wired In Type Constructors for Representation Types} -%* * -%************************************************************************ - -The following code defines the wired in datatypes cross, plus, unit -and c_of needed for the generic methods. - -Ok, so the basic story is that for each type constructor I need to -create 2 things - a TyCon and a DataCon and then we are basically -ok. There are going to be no arguments passed to these functions -because -well- there is nothing to pass to these functions. - -\begin{code} -crossTyCon :: TyCon -crossTyCon = pcNonRecDataTyCon crossTyConName alpha_beta_tyvars [] [crossDataCon] - -crossDataCon :: DataCon -crossDataCon = pcDataCon crossDataConName alpha_beta_tyvars [] [alphaTy, betaTy] crossTyCon - -plusTyCon :: TyCon -plusTyCon = pcNonRecDataTyCon plusTyConName alpha_beta_tyvars [] [inlDataCon, inrDataCon] - -inlDataCon, inrDataCon :: DataCon -inlDataCon = pcDataCon inlDataConName alpha_beta_tyvars [] [alphaTy] plusTyCon -inrDataCon = pcDataCon inrDataConName alpha_beta_tyvars [] [betaTy] plusTyCon - -genUnitTyCon :: TyCon -- The "1" type constructor for generics -genUnitTyCon = pcNonRecDataTyCon genUnitTyConName [] [] [genUnitDataCon] - -genUnitDataCon :: DataCon -genUnitDataCon = pcDataCon genUnitDataConName [] [] [] genUnitTyCon -\end{code} diff --git a/ghc/compiler/rename/RnBinds.lhs b/ghc/compiler/rename/RnBinds.lhs index 461016a228..3a72f3f0d8 100644 --- a/ghc/compiler/rename/RnBinds.lhs +++ b/ghc/compiler/rename/RnBinds.lhs @@ -18,7 +18,7 @@ module RnBinds ( import HsSyn -import HsBinds ( eqHsSig, hsSigDoc ) +import HsBinds ( hsSigDoc, sigLoc, eqHsSig ) import RdrHsSyn import RnHsSyn import TcRnMonad @@ -33,6 +33,7 @@ import CmdLineOpts ( DynFlag(..) ) import Digraph ( SCC(..), stronglyConnComp ) import Name ( Name, nameOccName, nameSrcLoc ) import NameSet +import PrelNames ( isUnboundName ) import RdrName ( RdrName, rdrNameOcc ) import BasicTypes ( RecFlag(..), TopLevelFlag(..), isTopLevel ) import List ( unzip4 ) @@ -154,7 +155,7 @@ rnTopMonoBinds :: RdrNameMonoBinds -> RnM (RenamedHsBinds, DefUses) -- The binders of the binding are in scope already; --- the top level scope resoluttion does that +-- the top level scope resolution does that rnTopMonoBinds mbinds sigs = bindPatSigTyVars (collectSigTysFromMonoBinds mbinds) $ \ _ -> @@ -199,7 +200,6 @@ rnMonoBindsAndThen mbinds sigs thing_inside -- Non-empty monobinds let all_uses = duUses bind_dus `plusFV` result_fvs bndrs = duDefs bind_dus - real_uses = findUses bind_dus result_fvs unused_bndrs = nameSetToList (bndrs `minusNameSet` all_uses) in warnUnusedLocalBinds unused_bndrs `thenM_` @@ -260,11 +260,9 @@ rnMonoBinds top_lvl mbinds sigs -- Warn about missing signatures, -- but only at top level, and not in interface mode -- (The latter is important when renaming bindings from 'deriving' clauses.) - getModeRn `thenM` \ mode -> doptM Opt_WarnMissingSigs `thenM` \ warn_missing_sigs -> (if isTopLevel top_lvl && - warn_missing_sigs && - not (isInterfaceMode mode) + warn_missing_sigs then let type_sig_vars = [n | Sig n _ _ <- siglist] un_sigd_binders = filter (not . (`elem` type_sig_vars)) @@ -322,13 +320,14 @@ flattenMonoBinds sigs (FunMonoBind name inf matches locn) FunMonoBind new_name inf new_matches locn, sigs_for_me )] - sigsForMe names_bound_here sigs = foldlM check [] (filter (sigForThisGroup names_bound_here) sigs) where + -- sigForThisGroup only returns signatures for + -- which sigName returns a Just check sigs sig = case filter (eqHsSig sig) sigs of [] -> returnM (sig:sigs) - other -> dupSigDeclErr sig `thenM_` + other -> dupSigDeclErr sig other `thenM_` returnM sigs \end{code} @@ -377,7 +376,7 @@ rnMethodBinds cls gen_tyvars (FunMonoBind name inf matches locn) = extendTyVarEnvFVRn gen_tvs $ rnMatch (FunRhs sel_name) match where - tvs = map rdrNameOcc (extractHsTyRdrNames ty) + tvs = map rdrNameOcc (extractHsTyRdrTyVars ty) gen_tvs = [tv | tv <- gen_tyvars, nameOccName tv `elem` tvs] rn_match sel_name match = rnMatch (FunRhs sel_name) match @@ -464,9 +463,12 @@ checkSigs ok_sig sigs -- Check for (a) duplicate signatures -- (b) signatures for things not in this group -- Well, I can't see the check for (a)... ToDo! - = mappM_ unknownSigErr bad_sigs + = mappM_ unknownSigErr (filter bad sigs) where - bad_sigs = filter (not . ok_sig) sigs + bad sig = not (ok_sig sig) && + case sigName sig of + Just n | isUnboundName n -> False -- Don't complain about an unbound name again + other -> True -- We use lookupSigOccRn in the signatures, which is a little bit unsatisfactory -- because this won't work for: @@ -482,7 +484,7 @@ renameSigs sigs = mappM renameSig (filter (not . isFixitySig) sigs) -- Remove fixity sigs which have been dealt with already renameSig :: Sig RdrName -> RnM (Sig Name) --- ClassOpSig, FixitSig is renamed elsewhere. +-- FixitSig is renamed elsewhere. renameSig (Sig v ty src_loc) = addSrcLoc src_loc $ lookupSigOccRn v `thenM` \ new_v -> @@ -514,12 +516,13 @@ renameSig (InlineSig b v p src_loc) %************************************************************************ \begin{code} -dupSigDeclErr sig +dupSigDeclErr sig sigs = addSrcLoc loc $ - addErr (sep [ptext SLIT("Duplicate") <+> what_it_is <> colon, - ppr sig]) + addErr (vcat [ptext SLIT("Duplicate") <+> what_it_is <> colon, + nest 2 (vcat (map ppr_sig (sig:sigs)))]) where (what_it_is, loc) = hsSigDoc sig + ppr_sig sig = ppr (sigLoc sig) <> colon <+> ppr sig unknownSigErr sig = addSrcLoc loc $ diff --git a/ghc/compiler/rename/RnEnv.lhs b/ghc/compiler/rename/RnEnv.lhs index 84d0f69ac0..708f509e57 100644 --- a/ghc/compiler/rename/RnEnv.lhs +++ b/ghc/compiler/rename/RnEnv.lhs @@ -4,56 +4,55 @@ \section[RnEnv]{Environment manipulation for the renamer monad} \begin{code} -module RnEnv where -- Export everything +module RnEnv ( + newTopSrcBinder, + lookupBndrRn,lookupTopBndrRn, + lookupOccRn, lookupGlobalOccRn, + lookupTopFixSigNames, lookupSrcOcc_maybe, + lookupFixityRn, lookupSigOccRn, lookupInstDeclBndr, + lookupSyntaxName, lookupSyntaxNames, lookupImportedName, + + newLocalsRn, newIPNameRn, + bindLocalNames, bindLocalNamesFV, + bindLocalsRn, bindLocalsFV, bindLocatedLocalsRn, + bindPatSigTyVars, bindPatSigTyVarsFV, + bindTyVarsRn, extendTyVarEnvFVRn, + bindLocalFixities, + + checkDupNames, mapFvRn, + warnUnusedMatches, warnUnusedModules, warnUnusedImports, + warnUnusedTopBinds, warnUnusedLocalBinds, + dataTcOccs, unknownNameErr + ) where #include "HsVersions.h" -import {-# SOURCE #-} RnHiFiles( loadInterface ) - -import FlattenInfo ( namesNeededForFlattening ) +import LoadIface ( loadSrcInterface ) +import IfaceEnv ( lookupOrig, newGlobalBinder, newIPName ) import HsSyn import RdrHsSyn ( RdrNameHsType, RdrNameFixitySig, extractHsTyRdrTyVars ) import RdrName ( RdrName, rdrNameModule, rdrNameOcc, isQual, isUnqual, isOrig, - mkRdrUnqual, mkRdrQual, setRdrNameSpace, rdrNameOcc, - lookupRdrEnv, rdrEnvToList, elemRdrEnv, - extendRdrEnv, addListToRdrEnv, emptyRdrEnv, - isExact_maybe, unqualifyRdrName + mkRdrUnqual, setRdrNameSpace, rdrNameOcc, + pprGlobalRdrEnv, lookupGRE_RdrName, + isExact_maybe, isSrcRdrName, + GlobalRdrElt(..), GlobalRdrEnv, lookupGlobalRdrEnv, + isLocalGRE, extendLocalRdrEnv, elemLocalRdrEnv, lookupLocalRdrEnv, + Provenance(..), pprNameProvenance, ImportSpec(..) ) import HsTypes ( hsTyVarName, replaceTyVarName ) -import HscTypes ( Provenance(..), pprNameProvenance, hasBetterProv, - ImportReason(..), GlobalRdrEnv, GlobalRdrElt(..), - GenAvailInfo(..), AvailInfo, Avails, - ModIface(..), NameCache(..), OrigNameCache, - Deprecations(..), lookupDeprec, isLocalGRE, - extendLocalRdrEnv, availName, availNames, - lookupFixity - ) +import HscTypes ( availNames, ModIface(..), FixItem(..), lookupFixity ) import TcRnMonad -import Name ( Name, getName, nameIsLocalOrFrom, - isWiredInName, mkInternalName, mkExternalName, mkIPName, - nameSrcLoc, nameOccName, setNameSrcLoc, nameModule ) +import Name ( Name, nameIsLocalOrFrom, mkInternalName, + nameSrcLoc, nameOccName, nameModuleName, nameParent ) import NameSet -import OccName ( OccName, tcName, isDataOcc, occNameFlavour, reportIfUnused ) -import Module ( Module, ModuleName, moduleName, mkHomeModule, - lookupModuleEnv, lookupModuleEnvByName, extendModuleEnv_C ) -import PrelNames ( mkUnboundName, intTyConName, - boolTyConName, funTyConName, - unpackCStringName, unpackCStringFoldrName, unpackCStringUtf8Name, - eqStringName, printName, integerTyConName, - bindIOName, returnIOName, failIOName, thenIOName, - rOOT_MAIN_Name - ) -#ifdef GHCI -import DsMeta ( templateHaskellNames, qTyConName ) -#endif -import TysWiredIn ( unitTyCon ) -- A little odd -import Finder ( findModule ) -import FiniteMap +import OccName ( tcName, isDataOcc, occNameFlavour, reportIfUnused ) +import Module ( Module, ModuleName, moduleName, mkHomeModule ) +import PrelNames ( mkUnboundName, rOOT_MAIN_Name, iNTERACTIVE ) import UniqSupply -import SrcLoc ( SrcLoc, importedSrcLoc ) +import BasicTypes ( IPName, mapIPName ) +import SrcLoc ( SrcLoc ) import Outputable import ListSetOps ( removeDups, equivClasses ) -import BasicTypes ( mapIPName, FixitySig(..) ) import List ( nub ) import CmdLineOpts import FastString ( FastString ) @@ -61,13 +60,13 @@ import FastString ( FastString ) %********************************************************* %* * -\subsection{Making new names} + Source-code binders %* * %********************************************************* \begin{code} -newTopBinder :: Module -> RdrName -> SrcLoc -> TcRn m Name -newTopBinder mod rdr_name loc +newTopSrcBinder :: Module -> Maybe Name -> (RdrName, SrcLoc) -> RnM Name +newTopSrcBinder mod mb_parent (rdr_name, loc) | Just name <- isExact_maybe rdr_name = returnM name @@ -83,154 +82,17 @@ newTopBinder mod rdr_name loc -- not from the environment. In principle, it'd be fine to have an -- arbitrary mixture of external core definitions in a single module, -- (apart from module-initialisation issues, perhaps). - newGlobalName (mkHomeModule rdr_mod) (rdrNameOcc rdr_name) loc + newGlobalBinder (mkHomeModule rdr_mod) (rdrNameOcc rdr_name) mb_parent loc | otherwise - = newGlobalName mod (rdrNameOcc rdr_name) loc + = newGlobalBinder mod (rdrNameOcc rdr_name) mb_parent loc where rdr_mod = rdrNameModule rdr_name - -newGlobalName :: Module -> OccName -> SrcLoc -> TcRn m Name -newGlobalName mod occ loc - = -- First check the cache - getNameCache `thenM` \ name_supply -> - case lookupOrigNameCache (nsNames name_supply) mod occ of - - -- A hit in the cache! We are at the binding site of the name. - -- This is the moment when we know the defining SrcLoc - -- of the Name, so we set the SrcLoc of the name we return. - -- - -- Main reason: then (bogus) multiple bindings of the same Name - -- get different SrcLocs can can be reported as such. - -- - -- Possible other reason: it might be in the cache because we - -- encountered an occurrence before the binding site for an - -- implicitly-imported Name. Perhaps the current SrcLoc is - -- better... but not really: it'll still just say 'imported' - -- - -- IMPORTANT: Don't mess with wired-in names. - -- Their wired-in-ness is in the SrcLoc - - Just name | isWiredInName name -> returnM name - | otherwise -> returnM (setNameSrcLoc name loc) - - -- Miss in the cache! - -- Build a completely new Name, and put it in the cache - Nothing -> addNewName name_supply mod occ loc - --- Look up a "system name" in the name cache. --- This is done by the type checker... -lookupSysName :: Name -- Base name - -> (OccName -> OccName) -- Occurrence name modifier - -> TcRn m Name -- System name -lookupSysName base_name mk_sys_occ - = newGlobalName (nameModule base_name) - (mk_sys_occ (nameOccName base_name)) - (nameSrcLoc base_name) - - -newGlobalNameFromRdrName rdr_name -- Qualified original name - = newGlobalName2 (rdrNameModule rdr_name) (rdrNameOcc rdr_name) - -newGlobalName2 :: ModuleName -> OccName -> TcRn m Name - -- This one starts with a ModuleName, not a Module, because - -- we may be simply looking at an occurrence M.x in an interface file. - -- - -- Used for *occurrences*. Even if we get a miss in the - -- original-name cache, we make a new External Name. - -- We get its Module either from the OrigNameCache, or (if this - -- is the first Name from that module) from the Finder - -- - -- In the case of a miss, we have to make up the SrcLoc, but that's - -- OK: it must be an implicitly-imported Name, and that never occurs - -- in an error message. - -newGlobalName2 mod_name occ - = getNameCache `thenM` \ name_supply -> - let - new_name mod = addNewName name_supply mod occ importedSrcLoc - in - case lookupModuleEnvByName (nsNames name_supply) mod_name of - Just (mod, occ_env) -> - -- There are some names from this module already - -- Next, look up in the OccNameEnv - case lookupFM occ_env occ of - Just name -> returnM name - Nothing -> new_name mod - - Nothing -> -- No names from this module yet - ioToTcRn (findModule mod_name) `thenM` \ mb_loc -> - case mb_loc of - Right (mod, _) -> new_name mod - Left files -> - getDOpts `thenM` \ dflags -> - addErr (noIfaceErr dflags mod_name False files) `thenM_` - -- Things have really gone wrong at this point, - -- so having the wrong package info in the - -- Module is the least of our worries. - new_name (mkHomeModule mod_name) - - -newIPName rdr_name_ip - = getNameCache `thenM` \ name_supply -> - let - ipcache = nsIPs name_supply - in - case lookupFM ipcache key of - Just name_ip -> returnM name_ip - Nothing -> setNameCache new_ns `thenM_` - returnM name_ip - where - (us', us1) = splitUniqSupply (nsUniqs name_supply) - uniq = uniqFromSupply us1 - name_ip = mapIPName mk_name rdr_name_ip - mk_name rdr_name = mkIPName uniq (rdrNameOcc rdr_name) - new_ipcache = addToFM ipcache key name_ip - new_ns = name_supply {nsUniqs = us', nsIPs = new_ipcache} - where - key = rdr_name_ip -- Ensures that ?x and %x get distinct Names - --- A local helper function -addNewName name_supply mod occ loc - = setNameCache new_name_supply `thenM_` - returnM name - where - (new_name_supply, name) = newExternalName name_supply mod occ loc - - -newExternalName :: NameCache -> Module -> OccName -> SrcLoc - -> (NameCache,Name) --- Allocate a new unique, manufacture a new External Name, --- put it in the cache, and return the two -newExternalName name_supply mod occ loc - = (new_name_supply, name) - where - (us', us1) = splitUniqSupply (nsUniqs name_supply) - uniq = uniqFromSupply us1 - name = mkExternalName uniq mod occ loc - new_cache = extend_name_cache (nsNames name_supply) mod occ name - new_name_supply = name_supply {nsUniqs = us', nsNames = new_cache} - -lookupOrigNameCache :: OrigNameCache -> Module -> OccName -> Maybe Name -lookupOrigNameCache nc mod occ - = case lookupModuleEnv nc mod of - Nothing -> Nothing - Just (_, occ_env) -> lookupFM occ_env occ - -extendOrigNameCache :: OrigNameCache -> Name -> OrigNameCache -extendOrigNameCache nc name - = extend_name_cache nc (nameModule name) (nameOccName name) name - -extend_name_cache :: OrigNameCache -> Module -> OccName -> Name -> OrigNameCache -extend_name_cache nc mod occ name - = extendModuleEnv_C combine nc mod (mod, unitFM occ name) - where - combine (mod, occ_env) _ = (mod, addToFM occ_env occ name) \end{code} %********************************************************* %* * -\subsection{Looking up names} + Source code occurrences %* * %********************************************************* @@ -239,47 +101,28 @@ Looking up a name in the RnEnv. \begin{code} lookupBndrRn rdr_name = getLocalRdrEnv `thenM` \ local_env -> - case lookupRdrEnv local_env rdr_name of + case lookupLocalRdrEnv local_env rdr_name of Just name -> returnM name Nothing -> lookupTopBndrRn rdr_name -lookupTopBndrRn rdr_name --- Look up a top-level local binder. We may be looking up an unqualified 'f', +lookupTopBndrRn :: RdrName -> RnM Name +-- Look up a top-level source-code binder. We may be looking up an unqualified 'f', -- and there may be several imported 'f's too, which must not confuse us. +-- For example, this is OK: +-- import Foo( f ) +-- infix 9 f -- The 'f' here does not need to be qualified +-- f x = x -- Nor here, of course -- So we have to filter out the non-local ones. +-- -- A separate function (importsFromLocalDecls) reports duplicate top level -- decls, so here it's safe just to choose an arbitrary one. - +-- -- There should never be a qualified name in a binding position in Haskell, -- but there can be if we have read in an external-Core file. -- The Haskell parser checks for the illegal qualified name in Haskell -- source files, so we don't need to do so here. - = getModeRn `thenM` \ mode -> - case mode of - InterfaceMode mod -> - getSrcLocM `thenM` \ loc -> - newTopBinder mod rdr_name loc - - other -> lookupTopSrcBndr rdr_name - -lookupTopSrcBndr :: RdrName -> TcRn m Name -lookupTopSrcBndr rdr_name - = lookupTopSrcBndr_maybe rdr_name `thenM` \ maybe_name -> - case maybe_name of - Just name -> returnM name - Nothing -> unboundName rdr_name - - -lookupTopSrcBndr_maybe :: RdrName -> TcRn m (Maybe Name) --- Look up a source-code binder - --- Ignores imported names; for example, this is OK: --- import Foo( f ) --- infix 9 f -- The 'f' here does not need to be qualified --- f x = x -- Nor here, of course - -lookupTopSrcBndr_maybe rdr_name +lookupTopBndrRn rdr_name | Just name <- isExact_maybe rdr_name -- This is here just to catch the PrelBase defn of (say) [] and similar -- The parser reads the special syntax and returns an Exact RdrName @@ -292,19 +135,24 @@ lookupTopSrcBndr_maybe rdr_name -- data T = (,) Int Int -- unless we are in GHC.Tup = getModule `thenM` \ mod -> - checkErr (moduleName mod == moduleName (nameModule name)) + checkErr (moduleName mod == nameModuleName name) (badOrigBinding rdr_name) `thenM_` - returnM (Just name) + returnM name + + | isOrig rdr_name + -- This deals with the case of derived bindings, where + -- we don't bother to call newTopSrcBinder first + -- We assume there is no "parent" name + = getSrcLocM `thenM` \ loc -> + newGlobalBinder (mkHomeModule (rdrNameModule rdr_name)) + (rdrNameOcc rdr_name) Nothing loc | otherwise - = getGlobalRdrEnv `thenM` \ global_env -> - case lookupRdrEnv global_env rdr_name of - Nothing -> returnM Nothing - Just gres -> case [gre_name gre | gre <- gres, isLocalGRE gre] of - [] -> returnM Nothing - (n:ns) -> returnM (Just n) + = do { mb_gre <- lookupGreLocalRn rdr_name + ; case mb_gre of + Nothing -> unboundName rdr_name + Just gre -> returnM (gre_name gre) } - -- lookupSigOccRn is used for type signatures and pragmas -- Is this valid? -- module A @@ -323,182 +171,157 @@ lookupSigOccRn = lookupBndrRn -- disambiguate. lookupInstDeclBndr :: Name -> RdrName -> RnM Name - -- We use the selector name as the binder lookupInstDeclBndr cls_name rdr_name - | isUnqual rdr_name - = -- Find all the things the class op name maps to - -- and pick the one with the right parent name - getGblEnv `thenM` \ gbl_env -> - let - avail_env = imp_env (tcg_imports gbl_env) - occ = rdrNameOcc rdr_name - in - case lookupAvailEnv_maybe avail_env cls_name of - Nothing -> - -- If the class itself isn't in scope, then cls_name will - -- be unboundName, and there'll already be an error for - -- that in the error list. Example: - -- e.g. import Prelude hiding( Ord ) - -- instance Ord T where ... - -- The program is wrong, but that should not cause a crash. - returnM (mkUnboundName rdr_name) - - Just (AvailTC _ ns) -> case [n | n <- ns, nameOccName n == occ] of - (n:ns)-> ASSERT( null ns ) returnM n - [] -> unboundName rdr_name - - other -> pprPanic "lookupInstDeclBndr" (ppr cls_name) - - - | otherwise -- Occurs in derived instances, where we just - -- refer directly to the right method, and avail_env - -- isn't available + | isUnqual rdr_name -- Find all the things the rdr-name maps to + = do { -- and pick the one with the right parent name + let { is_op gre = cls_name == nameParent (gre_name gre) + ; occ = rdrNameOcc rdr_name + ; lookup_fn env = filter is_op (lookupGlobalRdrEnv env occ) } + ; mb_gre <- lookupGreRn_help rdr_name lookup_fn + ; case mb_gre of + Just gre -> return (gre_name gre) + Nothing -> do { addErr (unknownInstBndrErr cls_name rdr_name) + ; return (mkUnboundName rdr_name) } } + + | otherwise -- Occurs in derived instances, where we just + -- refer directly to the right method = ASSERT2( not (isQual rdr_name), ppr rdr_name ) -- NB: qualified names are rejected by the parser - lookupOrigName rdr_name + lookupImportedName rdr_name +newIPNameRn :: IPName RdrName -> TcRnIf m n (IPName Name) +newIPNameRn ip_rdr = newIPName (mapIPName rdrNameOcc ip_rdr) -lookupSysBndr :: RdrName -> RnM Name --- Used for the 'system binders' in a data type or class declaration --- Do *not* look up in the RdrEnv; these system binders are never in scope --- Instead, get the module from the monad... but remember that --- where the module is depends on whether we are renaming source or --- interface file stuff -lookupSysBndr rdr_name - = getSrcLocM `thenM` \ loc -> - getModeRn `thenM` \ mode -> - case mode of - InterfaceMode mod -> newTopBinder mod rdr_name loc - other -> getModule `thenM` \ mod -> - newTopBinder mod rdr_name loc +-------------------------------------------------- +-- Occurrences +-------------------------------------------------- -- lookupOccRn looks up an occurrence of a RdrName lookupOccRn :: RdrName -> RnM Name lookupOccRn rdr_name = getLocalRdrEnv `thenM` \ local_env -> - case lookupRdrEnv local_env rdr_name of + case lookupLocalRdrEnv local_env rdr_name of Just name -> returnM name Nothing -> lookupGlobalOccRn rdr_name +lookupGlobalOccRn :: RdrName -> RnM Name -- lookupGlobalOccRn is like lookupOccRn, except that it looks in the global -- environment. It's used only for -- record field names -- class op names in class and instance decls lookupGlobalOccRn rdr_name - = getModeRn `thenM` \ mode -> - case mode of - InterfaceMode mod -> lookupIfaceName mod rdr_name - SourceMode -> lookupSrcName rdr_name - - CmdLineMode - | not (isQual rdr_name) -> - lookupSrcName rdr_name - - -- We allow qualified names on the command line to refer to - -- *any* name exported by any module in scope, just as if - -- there was an "import qualified M" declaration for every - -- module. - -- - -- First look up the name in the normal environment. If - -- it isn't there, we manufacture a new occurrence of an - -- original name. - | otherwise -> - lookupSrcName_maybe rdr_name `thenM` \ mb_name -> - case mb_name of - Just name -> returnM name - Nothing -> lookupQualifiedName rdr_name + | not (isSrcRdrName rdr_name) + = lookupImportedName rdr_name + + | otherwise + = -- First look up the name in the normal environment. + lookupGreRn rdr_name `thenM` \ mb_gre -> + case mb_gre of { + Just gre -> returnM (gre_name gre) ; + Nothing -> + + -- We allow qualified names on the command line to refer to + -- *any* name exported by any module in scope, just as if + -- there was an "import qualified M" declaration for every + -- module. + getModule `thenM` \ mod -> + if isQual rdr_name && mod == iNTERACTIVE then + -- This test is not expensive, + lookupQualifiedName rdr_name -- and only happens for failed lookups + else + unboundName rdr_name } + +lookupImportedName :: RdrName -> TcRnIf m n Name +-- Lookup the occurrence of an imported name +-- The RdrName is *always* qualified or Exact +-- Treat it as an original name, and conjure up the Name +-- Usually it's Exact or Orig, but it can be Qual if it +-- comes from an hi-boot file. (This minor infelicity is +-- just to reduce duplication in the parser.) +lookupImportedName rdr_name + | Just n <- isExact_maybe rdr_name + -- This happens in derived code + = returnM n + + | otherwise -- Always Orig, even when reading a .hi-boot file + = ASSERT( not (isUnqual rdr_name) ) + lookupOrig (rdrNameModule rdr_name) (rdrNameOcc rdr_name) + +unboundName :: RdrName -> RnM Name +unboundName rdr_name + = do { addErr (unknownNameErr rdr_name) + ; env <- getGlobalRdrEnv; + ; traceRn (vcat [unknownNameErr rdr_name, + ptext SLIT("Global envt is:"), + nest 3 (pprGlobalRdrEnv env)]) + ; returnM (mkUnboundName rdr_name) } + +-------------------------------------------------- +-- Lookup in the Global RdrEnv of the module +-------------------------------------------------- + +lookupSrcOcc_maybe :: RdrName -> RnM (Maybe Name) +-- No filter function; does not report an error on failure +lookupSrcOcc_maybe rdr_name + = do { mb_gre <- lookupGreRn rdr_name + ; case mb_gre of + Nothing -> returnM Nothing + Just gre -> returnM (Just (gre_name gre)) } + +------------------------- +lookupGreRn :: RdrName -> RnM (Maybe GlobalRdrElt) +-- Just look up the RdrName in the GlobalRdrEnv +lookupGreRn rdr_name + = lookupGreRn_help rdr_name (lookupGRE_RdrName rdr_name) + +lookupGreLocalRn :: RdrName -> RnM (Maybe GlobalRdrElt) +-- Similar, but restricted to locally-defined things +lookupGreLocalRn rdr_name + = lookupGreRn_help rdr_name lookup_fn + where + lookup_fn env = filter isLocalGRE (lookupGRE_RdrName rdr_name env) + +lookupGreRn_help :: RdrName -- Only used in error message + -> (GlobalRdrEnv -> [GlobalRdrElt]) -- Lookup function + -> RnM (Maybe GlobalRdrElt) +-- Checks for exactly one match; reports deprecations +-- Returns Nothing, without error, if too few +lookupGreRn_help rdr_name lookup + = do { env <- getGlobalRdrEnv + ; case lookup env of + [] -> returnM Nothing + [gre] -> case gre_deprec gre of + Nothing -> returnM (Just gre) + Just _ -> do { warnDeprec gre + ; returnM (Just gre) } + gres -> do { addNameClashErrRn rdr_name gres + ; returnM (Just (head gres)) } } + +------------------------------ +-- GHCi support +------------------------------ -- A qualified name on the command line can refer to any module at all: we -- try to load the interface if we don't already have it. -lookupQualifiedName :: RdrName -> TcRn m Name +lookupQualifiedName :: RdrName -> RnM Name lookupQualifiedName rdr_name = let mod = rdrNameModule rdr_name occ = rdrNameOcc rdr_name in - loadInterface (ppr rdr_name) mod (ImportByUser False) `thenM` \ iface -> - case [ name | (_,avails) <- mi_exports iface, - avail <- avails, - name <- availNames avail, - nameOccName name == occ ] of - (n:ns) -> ASSERT (null ns) returnM n - _ -> unboundName rdr_name - -lookupSrcName :: RdrName -> TcRn m Name -lookupSrcName rdr_name - = lookupSrcName_maybe rdr_name `thenM` \ mb_name -> - case mb_name of - Nothing -> unboundName rdr_name - Just name -> returnM name - -lookupSrcName_maybe :: RdrName -> TcRn m (Maybe Name) -lookupSrcName_maybe rdr_name - | Just name <- isExact_maybe rdr_name -- Can occur in source code too - = returnM (Just name) - - | isOrig rdr_name -- An original name - = newGlobalNameFromRdrName rdr_name `thenM` \ name -> - returnM (Just name) - - | otherwise - = lookupGRE rdr_name `thenM` \ mb_gre -> - case mb_gre of - Nothing -> returnM Nothing - Just gre -> returnM (Just (gre_name gre)) - -lookupGRE :: RdrName -> TcRn m (Maybe GlobalRdrElt) -lookupGRE rdr_name - = getGlobalRdrEnv `thenM` \ global_env -> - case lookupRdrEnv global_env rdr_name of - Just [gre] -> case gre_deprec gre of - Nothing -> returnM (Just gre) - Just _ -> warnDeprec gre `thenM_` - returnM (Just gre) - Just stuff@(gre : _) -> addNameClashErrRn rdr_name stuff `thenM_` - returnM (Just gre) - Nothing -> return Nothing - -lookupIfaceName :: Module -> RdrName -> TcRn m Name - -- An Unqual is allowed; interface files contain - -- unqualified names for locally-defined things, such as - -- constructors of a data type. -lookupIfaceName mod rdr_name - | isUnqual rdr_name = newGlobalName mod (rdrNameOcc rdr_name) importedSrcLoc - | otherwise = lookupOrigName rdr_name - -lookupOrigName :: RdrName -> TcRn m Name - -- Just for original or exact names -lookupOrigName rdr_name - | Just n <- isExact_maybe rdr_name - -- This happens in derived code, which we - -- rename in InterfaceMode - = returnM n - - | otherwise -- Usually Orig, but can be a Qual when - -- we are reading a .hi-boot file - = newGlobalNameFromRdrName rdr_name - - -dataTcOccs :: RdrName -> [RdrName] --- If the input is a data constructor, return both it and a type --- constructor. This is useful when we aren't sure which we are --- looking at. --- --- ToDo: If the user typed "[]" or "(,,)", we'll generate an Exact RdrName, --- and we don't have a systematic way to find the TyCon's Name from --- the DataCon's name. Sigh -dataTcOccs rdr_name - | isDataOcc occ = [rdr_name_tc, rdr_name] - | otherwise = [rdr_name] - where - occ = rdrNameOcc rdr_name - rdr_name_tc = setRdrNameSpace rdr_name tcName -\end{code} - -\begin{code} -unboundName rdr_name = addErr (unknownNameErr rdr_name) `thenM_` - returnM (mkUnboundName rdr_name) + loadSrcInterface doc mod False `thenM` \ iface -> + + case [ (mod,occ) | + (mod,avails) <- mi_exports iface, + avail <- avails, + name <- availNames avail, + name == occ ] of + ((mod,occ):ns) -> ASSERT (null ns) + lookupOrig mod occ + _ -> unboundName rdr_name + where + doc = ptext SLIT("Need to find") <+> ppr rdr_name \end{code} %********************************************************* @@ -508,6 +331,17 @@ unboundName rdr_name = addErr (unknownNameErr rdr_name) `thenM_` %********************************************************* \begin{code} +lookupTopFixSigNames :: RdrName -> RnM [Name] +-- GHC extension: look up both the tycon and data con +-- for con-like things +lookupTopFixSigNames rdr_name + | Just n <- isExact_maybe rdr_name + -- Special case for (:), which doesn't get into the GlobalRdrEnv + = return [n] -- For this we don't need to try the tycon too + | otherwise + = do { mb_gres <- mapM lookupGreLocalRn (dataTcOccs rdr_name) + ; return [gre_name gre | Just gre <- mb_gres] } + -------------------------------- bindLocalFixities :: [RdrNameFixitySig] -> RnM a -> RnM a -- Used for nested fixity decls @@ -521,7 +355,7 @@ bindLocalFixities fixes thing_inside rn_sig (FixitySig v fix src_loc) = addSrcLoc src_loc $ lookupSigOccRn v `thenM` \ new_v -> - returnM (new_v, FixitySig new_v fix src_loc) + returnM (new_v, (FixItem (rdrNameOcc v) fix src_loc)) \end{code} -------------------------------- @@ -545,6 +379,7 @@ lookupFixityRn name if nameIsLocalOrFrom this_mod name then -- It's defined in this module getFixityEnv `thenM` \ local_fix_env -> + traceRn (text "lookupFixityRn" <+> (ppr name $$ ppr local_fix_env)) `thenM_` returnM (lookupFixity local_fix_env name) else -- It's imported @@ -561,83 +396,37 @@ lookupFixityRn name -- nothing from B will be used). When we come across a use of -- 'f', we need to know its fixity, and it's then, and only -- then, that we load B.hi. That is what's happening here. - loadInterface doc name_mod ImportBySystem `thenM` \ iface -> - returnM (lookupFixity (mi_fixities iface) name) + loadSrcInterface doc name_mod False `thenM` \ iface -> + returnM (mi_fix_fn iface (nameOccName name)) where doc = ptext SLIT("Checking fixity for") <+> ppr name - name_mod = moduleName (nameModule name) -\end{code} - - -%********************************************************* -%* * -\subsection{Implicit free vars and sugar names} -%* * -%********************************************************* - -@getXImplicitFVs@ forces the renamer to slurp in some things which aren't -mentioned explicitly, but which might be needed by the type checker. + name_mod = nameModuleName name -\begin{code} -implicitStmtFVs source_fvs -- Compiling a statement - = stmt_fvs `plusFV` implicitModuleFVs source_fvs - where - stmt_fvs = mkFVs [printName, bindIOName, thenIOName, returnIOName, failIOName, - integerTyConName] - -- These are all needed implicitly when compiling a statement - -- See TcModule.tc_stmts - -- Reason for integerTyConName: consider this in GHCi - -- ghci> [] - -- We get an ambigous constraint (Show a), which we now default just like - -- numeric types... but unless we have the instance decl for Integer we - -- won't find a valid default! - -implicitModuleFVs source_fvs - = mkTemplateHaskellFVs source_fvs `plusFV` - namesNeededForFlattening `plusFV` - ubiquitousNames - - -thProxyName :: NameSet -mkTemplateHaskellFVs :: NameSet -> NameSet - -- This is a bit of a hack. When we see the Template-Haskell construct - -- [| expr |] - -- we are going to need lots of the ``smart constructors'' defined in - -- the main Template Haskell data type module. Rather than treat them - -- all as free vars at every occurrence site, we just make the Q type - -- consructor a free var.... and then use that here to haul in the others - -#ifdef GHCI ---------------- Template Haskell enabled -------------- -thProxyName = unitFV qTyConName - -mkTemplateHaskellFVs source_fvs - | qTyConName `elemNameSet` source_fvs = templateHaskellNames - | otherwise = emptyFVs - -#else ---------------- Template Haskell disabled -------------- - -thProxyName = emptyFVs -mkTemplateHaskellFVs source_fvs = emptyFVs -#endif --------------------------------------------------------- - --- ubiquitous_names are loaded regardless, because --- they are needed in virtually every program -ubiquitousNames - = mkFVs [unpackCStringName, unpackCStringFoldrName, - unpackCStringUtf8Name, eqStringName, - -- Virtually every program has error messages in it somewhere - getName unitTyCon, funTyConName, boolTyConName, intTyConName] - -- Add occurrences for very frequently used types. - -- (e.g. we don't want to be bothered with making - -- funTyCon a free var at every function application!) +dataTcOccs :: RdrName -> [RdrName] +-- If the input is a data constructor, return both it and a type +-- constructor. This is useful when we aren't sure which we are +-- looking at. +-- +-- ToDo: If the user typed "[]" or "(,,)", we'll generate an Exact RdrName, +-- and we don't have a systematic way to find the TyCon's Name from +-- the DataCon's name. Sigh +dataTcOccs rdr_name + | isDataOcc occ = [rdr_name_tc, rdr_name] + | otherwise = [rdr_name] + where + occ = rdrNameOcc rdr_name + rdr_name_tc = setRdrNameSpace rdr_name tcName \end{code} %************************************************************************ %* * -\subsection{Re-bindable desugaring names} + Rebindable names + Dealing with rebindable syntax is driven by the + Opt_NoImplicitPrelude dynamic flag. + + In "deriving" code we don't want to use rebindable syntax + so we switch off the flag locally + %* * %************************************************************************ @@ -675,15 +464,11 @@ lookupSyntaxName std_name = doptM Opt_NoImplicitPrelude `thenM` \ no_prelude -> if not no_prelude then normal_case else - getModeRn `thenM` \ mode -> - if isInterfaceMode mode then normal_case - -- Happens for 'derived' code where we don't want to rebind - else -- Get the similarly named thing from the local environment lookupOccRn (mkRdrUnqual (nameOccName std_name)) `thenM` \ usr_name -> - returnM (usr_name, mkFVs [usr_name, std_name]) + returnM (usr_name, unitFV usr_name) where - normal_case = returnM (std_name, unitFV std_name) + normal_case = returnM (std_name, emptyFVs) lookupSyntaxNames :: [Name] -- Standard names -> RnM (ReboundNames Name, FreeVars) -- See comments with HsExpr.ReboundNames @@ -691,15 +476,12 @@ lookupSyntaxNames std_names = doptM Opt_NoImplicitPrelude `thenM` \ no_prelude -> if not no_prelude then normal_case else - getModeRn `thenM` \ mode -> - if isInterfaceMode mode then normal_case - else -- Get the similarly named thing from the local environment mappM (lookupOccRn . mkRdrUnqual . nameOccName) std_names `thenM` \ usr_names -> - returnM (std_names `zip` map HsVar usr_names, mkFVs std_names `plusFV` mkFVs usr_names) + returnM (std_names `zip` map HsVar usr_names, mkFVs usr_names) where - normal_case = returnM (std_names `zip` map HsVar std_names, mkFVs std_names) + normal_case = returnM (std_names `zip` map HsVar std_names, emptyFVs) \end{code} @@ -728,56 +510,23 @@ bindLocatedLocalsRn :: SDoc -- Documentation string for error message -> ([Name] -> RnM a) -> RnM a bindLocatedLocalsRn doc_str rdr_names_w_loc enclosed_scope - = getModeRn `thenM` \ mode -> - getLocalRdrEnv `thenM` \ local_env -> - getGlobalRdrEnv `thenM` \ global_env -> + = ASSERT2( all (isUnqual . fst) rdr_names_w_loc, ppr rdr_names_w_loc ) + -- We only bind unqualified names here + -- lookupRdrEnv doesn't even attempt to look up a qualified RdrName - -- Check for duplicate names - checkDupOrQualNames doc_str rdr_names_w_loc `thenM_` + -- Check for duplicate names + checkDupNames doc_str rdr_names_w_loc `thenM_` -- Warn about shadowing, but only in source modules - let - check_shadow (rdr_name,loc) - | rdr_name `elemRdrEnv` local_env - || rdr_name `elemRdrEnv` global_env - = addSrcLoc loc $ addWarn (shadowedNameWarn rdr_name) - | otherwise - = returnM () - in - - (case mode of - SourceMode -> ifOptM Opt_WarnNameShadowing $ - mappM_ check_shadow rdr_names_w_loc - other -> returnM () - ) `thenM_` + ifOptM Opt_WarnNameShadowing + (checkShadowing doc_str rdr_names_w_loc) `thenM_` + -- Make fresh Names and extend the environment newLocalsRn rdr_names_w_loc `thenM` \ names -> - let - new_local_env = addListToRdrEnv local_env (map fst rdr_names_w_loc `zip` names) - in - setLocalRdrEnv new_local_env (enclosed_scope names) - -bindCoreLocalRn :: RdrName -> (Name -> RnM a) -> RnM a - -- A specialised variant when renaming stuff from interface - -- files (of which there is a lot) - -- * one at a time - -- * no checks for shadowing - -- * always imported - -- * deal with free vars -bindCoreLocalRn rdr_name enclosed_scope - = getSrcLocM `thenM` \ loc -> - getLocalRdrEnv `thenM` \ name_env -> - newUnique `thenM` \ uniq -> - let - name = mkInternalName uniq (rdrNameOcc rdr_name) loc - new_name_env = extendRdrEnv name_env rdr_name name - in - setLocalRdrEnv new_name_env (enclosed_scope name) + getLocalRdrEnv `thenM` \ local_env -> + setLocalRdrEnv (extendLocalRdrEnv local_env names) + (enclosed_scope names) -bindCoreLocalsRn [] thing_inside = thing_inside [] -bindCoreLocalsRn (b:bs) thing_inside = bindCoreLocalRn b $ \ name' -> - bindCoreLocalsRn bs $ \ names' -> - thing_inside (name':names') bindLocalNames names enclosed_scope = getLocalRdrEnv `thenM` \ name_env -> @@ -791,12 +540,6 @@ bindLocalNamesFV names enclosed_scope ------------------------------------- -bindLocalRn doc rdr_name enclosed_scope - = getSrcLocM `thenM` \ loc -> - bindLocatedLocalsRn doc [(rdr_name,loc)] $ \ (n:ns) -> - ASSERT( null ns ) - enclosed_scope n - bindLocalsRn doc rdr_names enclosed_scope = getSrcLocM `thenM` \ loc -> bindLocatedLocalsRn doc @@ -838,7 +581,7 @@ bindPatSigTyVars tys thing_inside let forall_tyvars = nub [ tv | ty <- tys, tv <- extractHsTyRdrTyVars ty, - not (tv `elemFM` name_env) + not (tv `elemLocalRdrEnv` name_env) ] -- The 'nub' is important. For example: -- f (x :: t) (y :: t) = .... @@ -858,126 +601,29 @@ bindPatSigTyVarsFV tys thing_inside returnM (result, fvs `delListFromNameSet` tvs) ------------------------------------- -checkDupOrQualNames, checkDupNames :: SDoc - -> [(RdrName, SrcLoc)] - -> TcRn m () - -- Works in any variant of the renamer monad - -checkDupOrQualNames doc_str rdr_names_w_loc - = -- Qualified names in patterns are now rejected by the parser - -- but I'm not 100% certain that it finds all cases, so I've left - -- this check in for now. Should go eventually. - -- Hmm. Sooner rather than later.. data type decls --- mappM_ (qualNameErr doc_str) quals `thenM_` - checkDupNames doc_str rdr_names_w_loc - where - quals = filter (isQual . fst) rdr_names_w_loc - +checkDupNames :: SDoc + -> [(RdrName, SrcLoc)] + -> RnM () checkDupNames doc_str rdr_names_w_loc = -- Check for duplicated names in a binding group mappM_ (dupNamesErr doc_str) dups where (_, dups) = removeDups (\(n1,l1) (n2,l2) -> n1 `compare` n2) rdr_names_w_loc -\end{code} - - -%************************************************************************ -%* * -\subsection{GlobalRdrEnv} -%* * -%************************************************************************ - -\begin{code} -mkGlobalRdrEnv :: ModuleName -- Imported module (after doing the "as M" name change) - -> Bool -- True <=> want unqualified import - -> (Name -> Provenance) - -> Avails -- Whats imported - -> Deprecations - -> GlobalRdrEnv - -mkGlobalRdrEnv this_mod unqual_imp mk_provenance avails deprecs - = gbl_env2 - where - -- Make the name environment. We're talking about a - -- single module here, so there must be no name clashes. - -- In practice there only ever will be if it's the module - -- being compiled. - - -- Add qualified names for the things that are available - -- (Qualified names are always imported) - gbl_env1 = foldl add_avail emptyRdrEnv avails - - -- Add unqualified names - gbl_env2 | unqual_imp = foldl add_unqual gbl_env1 (rdrEnvToList gbl_env1) - | otherwise = gbl_env1 - - add_unqual env (qual_name, elts) - = foldl add_one env elts - where - add_one env elt = addOneToGlobalRdrEnv env unqual_name elt - unqual_name = unqualifyRdrName qual_name - -- The qualified import should only have added one - -- binding for each qualified name! But if there's an error in - -- the module (multiple bindings for the same name) we may get - -- duplicates. So the simple thing is to do the fold. - - add_avail :: GlobalRdrEnv -> AvailInfo -> GlobalRdrEnv - add_avail env avail = foldl (add_name (availName avail)) env (availNames avail) - - add_name parent env name -- Add qualified name only - = addOneToGlobalRdrEnv env (mkRdrQual this_mod occ) elt - where - occ = nameOccName name - elt = GRE {gre_name = name, - gre_parent = if name == parent - then Nothing - else Just parent, - gre_prov = mk_provenance name, - gre_deprec = lookupDeprec deprecs name} -\end{code} - -\begin{code} -plusGlobalRdrEnv :: GlobalRdrEnv -> GlobalRdrEnv -> GlobalRdrEnv -plusGlobalRdrEnv env1 env2 = plusFM_C combine_globals env1 env2 - -addOneToGlobalRdrEnv :: GlobalRdrEnv -> RdrName -> GlobalRdrElt -> GlobalRdrEnv -addOneToGlobalRdrEnv env rdr_name name = addToFM_C combine_globals env rdr_name [name] - -delOneFromGlobalRdrEnv :: GlobalRdrEnv -> RdrName -> GlobalRdrEnv -delOneFromGlobalRdrEnv env rdr_name = delFromFM env rdr_name -combine_globals :: [GlobalRdrElt] -- Old - -> [GlobalRdrElt] -- New - -> [GlobalRdrElt] -combine_globals ns_old ns_new -- ns_new is often short - = foldr add ns_old ns_new - where - add n ns | any (is_duplicate n) ns_old = map (choose n) ns -- Eliminate duplicates - | otherwise = n:ns - - choose n m | n `beats` m = n - | otherwise = m - - g1 `beats` g2 = gre_name g1 == gre_name g2 && - gre_prov g1 `hasBetterProv` gre_prov g2 - - is_duplicate :: GlobalRdrElt -> GlobalRdrElt -> Bool - is_duplicate g1 g2 | isLocalGRE g1 && isLocalGRE g2 = False - is_duplicate g1 g2 = gre_name g1 == gre_name g2 +------------------------------------- +checkShadowing doc_str rdr_names_w_loc + = getLocalRdrEnv `thenM` \ local_env -> + getGlobalRdrEnv `thenM` \ global_env -> + let + check_shadow (rdr_name,loc) + | rdr_name `elemLocalRdrEnv` local_env + || not (null (lookupGRE_RdrName rdr_name global_env )) + = addSrcLoc loc $ addWarn (shadowedNameWarn doc_str rdr_name) + | otherwise = returnM () + in + mappM_ check_shadow rdr_names_w_loc \end{code} -We treat two bindings of a locally-defined name as a duplicate, -because they might be two separate, local defns and we want to report -and error for that, {\em not} eliminate a duplicate. - -On the other hand, if you import the same name from two different -import statements, we {\em do} want to eliminate the duplicate, not report -an error. - -If a module imports itself then there might be a local defn and an imported -defn of the same name; in this case the names will compare as equal, but -will still have different provenances. - %************************************************************************ %* * @@ -1002,7 +648,7 @@ mapFvRn f xs = mappM f xs `thenM` \ stuff -> %************************************************************************ \begin{code} -warnUnusedModules :: [ModuleName] -> TcRn m () +warnUnusedModules :: [ModuleName] -> RnM () warnUnusedModules mods = ifOptM Opt_WarnUnusedImports (mappM_ (addWarn . unused_mod) mods) where @@ -1011,20 +657,20 @@ warnUnusedModules mods parens (ptext SLIT("except perhaps instances visible in") <+> quotes (ppr m))] -warnUnusedImports, warnUnusedTopBinds :: [GlobalRdrElt] -> TcRn m () +warnUnusedImports, warnUnusedTopBinds :: [GlobalRdrElt] -> RnM () warnUnusedImports gres = ifOptM Opt_WarnUnusedImports (warnUnusedGREs gres) warnUnusedTopBinds gres = ifOptM Opt_WarnUnusedBinds (warnUnusedGREs gres) -warnUnusedLocalBinds, warnUnusedMatches :: [Name] -> TcRn m () +warnUnusedLocalBinds, warnUnusedMatches :: [Name] -> RnM () warnUnusedLocalBinds names = ifOptM Opt_WarnUnusedBinds (warnUnusedLocals names) warnUnusedMatches names = ifOptM Opt_WarnUnusedMatches (warnUnusedLocals names) ------------------------- -- Helpers -warnUnusedGREs gres = warnUnusedBinds [(n,p) | GRE {gre_name = n, gre_prov = p} <- gres] -warnUnusedLocals names = warnUnusedBinds [(n,LocalDef) | n<-names] +warnUnusedGREs gres = warnUnusedBinds [(n,Just p) | GRE {gre_name = n, gre_prov = p} <- gres] +warnUnusedLocals names = warnUnusedBinds [(n,Nothing) | n<-names] -warnUnusedBinds :: [(Name,Provenance)] -> TcRn m () +warnUnusedBinds :: [(Name,Maybe Provenance)] -> RnM () warnUnusedBinds names = mappM_ warnUnusedGroup groups where @@ -1037,7 +683,7 @@ warnUnusedBinds names ------------------------- -warnUnusedGroup :: [(Name,Provenance)] -> TcRn m () +warnUnusedGroup :: [(Name,Maybe Provenance)] -> RnM () warnUnusedGroup names = addSrcLoc def_loc $ addWarn $ @@ -1046,8 +692,10 @@ warnUnusedGroup names (name1, prov1) = head names loc1 = nameSrcLoc name1 (def_loc, msg) = case prov1 of - LocalDef -> (loc1, unused_msg) - NonLocalDef (UserImport mod loc _) -> (loc, imp_from mod) + Just (Imported is _) -> (is_loc imp_spec, imp_from (is_mod imp_spec)) + where + imp_spec = head is + other -> (loc1, unused_msg) unused_msg = text "Defined but not used" imp_from mod = text "Imported from" <+> quotes (ppr mod) <+> text "but not used" @@ -1062,46 +710,33 @@ addNameClashErrRn rdr_name (np1:nps) msgs = [ptext SLIT(" or") <+> mk_ref np | np <- nps] mk_ref gre = quotes (ppr (gre_name gre)) <> comma <+> pprNameProvenance gre -shadowedNameWarn shadow +shadowedNameWarn doc shadow = hsep [ptext SLIT("This binding for"), quotes (ppr shadow), ptext SLIT("shadows an existing binding")] + $$ doc unknownNameErr name - = sep [text flavour, ptext SLIT("not in scope:"), quotes (ppr name)] + = sep [text flavour <+> ptext SLIT("not in scope:"), quotes (ppr name)] where flavour = occNameFlavour (rdrNameOcc name) +unknownInstBndrErr cls op + = quotes (ppr op) <+> ptext SLIT("is not a (visible) method of class") <+> quotes (ppr cls) + badOrigBinding name = ptext SLIT("Illegal binding of built-in syntax:") <+> ppr (rdrNameOcc name) -- The rdrNameOcc is because we don't want to print Prelude.(,) -qualNameErr descriptor (name,loc) - = addSrcLoc loc $ - addErr (vcat [ ptext SLIT("Invalid use of qualified name") <+> quotes (ppr name), - descriptor]) - dupNamesErr descriptor ((name,loc) : dup_things) = addSrcLoc loc $ addErr ((ptext SLIT("Conflicting definitions for") <+> quotes (ppr name)) $$ descriptor) - -noIfaceErr dflags mod_name boot_file files - = ptext SLIT("Could not find interface file for") <+> quotes (ppr mod_name) - $$ extra - where - extra - | verbosity dflags < 3 = - text "(use -v to see a list of the files searched for)" - | otherwise = - hang (ptext SLIT("locations searched:")) 4 (vcat (map text files)) - -warnDeprec :: GlobalRdrElt -> TcRn m () +warnDeprec :: GlobalRdrElt -> RnM () warnDeprec (GRE {gre_name = name, gre_deprec = Just txt}) = ifOptM Opt_WarnDeprecations $ addWarn (sep [ text (occNameFlavour (nameOccName name)) <+> quotes (ppr name) <+> text "is deprecated:", nest 4 (ppr txt) ]) \end{code} - diff --git a/ghc/compiler/rename/RnExpr.lhs b/ghc/compiler/rename/RnExpr.lhs index daa9767c33..df881009e7 100644 --- a/ghc/compiler/rename/RnExpr.lhs +++ b/ghc/compiler/rename/RnExpr.lhs @@ -28,28 +28,22 @@ import RdrHsSyn import RnHsSyn import TcRnMonad import RnEnv +import RdrName ( plusGlobalRdrEnv ) import RnNames ( importsFromLocalDecls ) import RnTypes ( rnHsTypeFVs, rnPat, litFVs, rnOverLit, rnPatsAndThen, dupFieldErr, precParseErr, sectionPrecErr, patSigErr, checkTupSize ) import CmdLineOpts ( DynFlag(..) ) -import BasicTypes ( Fixity(..), FixityDirection(..), IPName(..), - defaultFixity, negateFixity, compareFixity ) -import PrelNames ( hasKey, assertIdKey, - foldrName, buildName, - enumClassName, +import BasicTypes ( Fixity(..), FixityDirection(..), negateFixity, compareFixity ) +import PrelNames ( hasKey, assertIdKey, assertErrorName, loopAName, choiceAName, appAName, arrAName, composeAName, firstAName, - splitName, fstName, sndName, ioDataConName, - replicatePName, mapPName, filterPName, - crossPName, zipPName, toPName, - enumFromToPName, enumFromThenToPName, assertErrorName, negateName, monadNames, mfixName ) import Name ( Name, nameOccName ) import NameSet import UnicodeUtil ( stringToUtf8 ) import UniqFM ( isNullUFM ) import UniqSet ( emptyUniqSet ) -import Util ( isSingleton, mapAndUnzip ) -import List ( intersectBy, unzip4 ) +import Util ( isSingleton ) +import List ( unzip4 ) import ListSetOps ( removeDups ) import Outputable import SrcLoc ( noSrcLoc ) @@ -172,13 +166,8 @@ rnExpr (HsVar v) returnM (HsVar name, unitFV name) rnExpr (HsIPVar v) - = newIPName v `thenM` \ name -> - let - fvs = case name of - Linear _ -> mkFVs [splitName, fstName, sndName] - Dupable _ -> emptyFVs - in - returnM (HsIPVar name, fvs) + = newIPNameRn v `thenM` \ name -> + returnM (HsIPVar name, emptyFVs) rnExpr (HsLit lit) = litFVs lit `thenM` \ fvs -> @@ -204,15 +193,11 @@ rnExpr (OpApp e1 op _ e2) -- Deal with fixity -- When renaming code synthesised from "deriving" declarations - -- we're in Interface mode, and we should ignore fixity; assume - -- that the deriving code generator got the association correct - -- Don't even look up the fixity when in interface mode - getModeRn `thenM` \ mode -> - (if isInterfaceMode mode - then returnM (OpApp e1' op' defaultFixity e2') - else lookupFixityRn op_name `thenM` \ fixity -> - mkOpAppRn e1' op' fixity e2' - ) `thenM` \ final_e -> + -- we used to avoid fixity stuff, but we can't easily tell any + -- more, so I've removed the test. Adding HsPars in TcGenDeriv + -- should prevent bad things happening. + lookupFixityRn op_name `thenM` \ fixity -> + mkOpAppRn e1' op' fixity e2' `thenM` \ final_e -> returnM (final_e, fv_e1 `plusFV` fv_op `plusFV` fv_e2) @@ -234,20 +219,20 @@ rnExpr e@(HsBracket br_body loc) = addSrcLoc loc $ checkTH e "bracket" `thenM_` rnBracket br_body `thenM` \ (body', fvs_e) -> - returnM (HsBracket body' loc, fvs_e `plusFV` thProxyName) + returnM (HsBracket body' loc, fvs_e) rnExpr e@(HsSplice n splice loc) = addSrcLoc loc $ checkTH e "splice" `thenM_` newLocalsRn [(n,loc)] `thenM` \ [n'] -> rnExpr splice `thenM` \ (splice', fvs_e) -> - returnM (HsSplice n' splice' loc, fvs_e `plusFV` thProxyName) + returnM (HsSplice n' splice' loc, fvs_e) rnExpr e@(HsReify (Reify flavour name)) = checkTH e "reify" `thenM_` lookupGlobalOccRn name `thenM` \ name' -> -- For now, we can only reify top-level things - returnM (HsReify (Reify flavour name'), unitFV name' `plusFV` thProxyName) + returnM (HsReify (Reify flavour name'), unitFV name') rnExpr section@(SectionL expr op) = rnExpr expr `thenM` \ (expr', fvs_expr) -> @@ -294,13 +279,8 @@ rnExpr e@(HsDo do_or_lc stmts _ _ src_loc) lookupSyntaxNames syntax_names `thenM` \ (syntax_names', monad_fvs) -> returnM (HsDo do_or_lc stmts' syntax_names' placeHolderType src_loc, - fvs `plusFV` implicit_fvs do_or_lc `plusFV` monad_fvs) + fvs `plusFV` monad_fvs) where - implicit_fvs PArrComp = mkFVs [replicatePName, mapPName, filterPName, crossPName, zipPName] - implicit_fvs ListComp = mkFVs [foldrName, buildName] - implicit_fvs DoExpr = emptyFVs - implicit_fvs MDoExpr = emptyFVs - syntax_names = case do_or_lc of DoExpr -> monadNames MDoExpr -> monadNames ++ [mfixName] @@ -312,8 +292,7 @@ rnExpr (ExplicitList _ exps) rnExpr (ExplicitPArr _ exps) = rnExprs exps `thenM` \ (exps', fvs) -> - returnM (ExplicitPArr placeHolderType exps', - fvs `addOneFV` toPName `addOneFV` parrTyCon_name) + returnM (ExplicitPArr placeHolderType exps', fvs) rnExpr e@(ExplicitTuple exps boxity) = checkTupSize tup_size `thenM_` @@ -355,12 +334,11 @@ rnExpr (HsType a) rnExpr (ArithSeqIn seq) = rnArithSeq seq `thenM` \ (new_seq, fvs) -> - returnM (ArithSeqIn new_seq, fvs `addOneFV` enumClassName) + returnM (ArithSeqIn new_seq, fvs) rnExpr (PArrSeqIn seq) = rnArithSeq seq `thenM` \ (new_seq, fvs) -> - returnM (PArrSeqIn new_seq, - fvs `plusFV` mkFVs [enumFromToPName, enumFromThenToPName]) + returnM (PArrSeqIn new_seq, fvs) \end{code} These three are pattern syntax appearing in expressions. @@ -1047,16 +1025,13 @@ right_op_ok fix1 other = True -- Parser initially makes negation bind more tightly than any other operator +-- And "deriving" code should respect this (use HsPar if not) mkNegAppRn neg_arg neg_name - = -#ifdef DEBUG - getModeRn `thenM` \ mode -> - ASSERT( not_op_app mode neg_arg ) -#endif + = ASSERT( not_op_app neg_arg ) returnM (NegApp neg_arg neg_name) -not_op_app SourceMode (OpApp _ _ _ _) = False -not_op_app mode other = True +not_op_app (OpApp _ _ _ _) = False +not_op_app other = True \end{code} \begin{code} @@ -1067,12 +1042,9 @@ checkPrecMatch False fn match checkPrecMatch True op (Match (p1:p2:_) _ _) -- True indicates an infix lhs - = getModeRn `thenM` \ mode -> - -- See comments with rnExpr (OpApp ...) - if isInterfaceMode mode - then returnM () - else checkPrec op p1 False `thenM_` - checkPrec op p2 True + = -- See comments with rnExpr (OpApp ...) about "deriving" + checkPrec op p1 False `thenM_` + checkPrec op p2 True checkPrecMatch True op _ = panic "checkPrecMatch" @@ -1129,7 +1101,7 @@ mkAssertErrorExpr expr = HsApp (HsVar assertErrorName) (HsLit msg) msg = HsStringPrim (mkFastString (stringToUtf8 (showSDoc (ppr sloc)))) in - returnM (expr, unitFV assertErrorName) + returnM (expr, emptyFVs) \end{code} %************************************************************************ diff --git a/ghc/compiler/rename/RnHiFiles.lhs b/ghc/compiler/rename/RnHiFiles.lhs deleted file mode 100644 index d83b88104a..0000000000 --- a/ghc/compiler/rename/RnHiFiles.lhs +++ /dev/null @@ -1,731 +0,0 @@ -% -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 -% -\section{Dealing with interface files} - -\begin{code} -module RnHiFiles ( - readIface, loadInterface, loadHomeInterface, - loadOrphanModules, - loadOldIface, - ParsedIface(..) - ) where - -#include "HsVersions.h" - -import DriverState ( v_GhcMode, isCompManagerMode ) -import DriverUtil ( replaceFilenameSuffix ) -import CmdLineOpts ( DynFlag(..) ) -import Parser ( parseIface ) -import HscTypes ( ModIface(..), emptyModIface, - ExternalPackageState(..), noDependencies, - VersionInfo(..), Usage(..), - lookupIfaceByModName, RdrExportItem, - IsBootInterface, - DeclsMap, GatedDecl, IfaceInsts, IfaceRules, mkIfaceDecls, - AvailInfo, GenAvailInfo(..), ParsedIface(..), IfaceDeprecs, - Avails, availNames, availName, Deprecations(..) - ) -import HsSyn ( TyClDecl(..), InstDecl(..), RuleDecl(..), ConDecl(..), - hsTyVarNames, splitHsInstDeclTy, tyClDeclName, tyClDeclNames - ) -import RdrHsSyn ( RdrNameTyClDecl, RdrNameInstDecl, RdrNameRuleDecl ) -import RnHsSyn ( RenamedInstDecl, RenamedRuleDecl, RenamedTyClDecl, - extractHsTyNames_s ) -import BasicTypes ( Version, FixitySig(..), Fixity(..), FixityDirection(..) ) -import RnSource ( rnIfaceRuleDecl, rnTyClDecl, rnInstDecl ) -import RnTypes ( rnHsType ) -import RnEnv -import TcRnMonad - -import PrelNames ( gHC_PRIM_Name, gHC_PRIM ) -import PrelInfo ( ghcPrimExports ) -import Name ( Name {-instance NamedThing-}, - nameModule, isInternalName ) -import NameEnv -import NameSet -import Id ( idName ) -import MkId ( seqId ) -import Packages ( basePackage ) -import Module ( Module, ModuleName, ModLocation(ml_hi_file), - moduleName, isHomeModule, mkPackageModule, - extendModuleEnv, lookupModuleEnvByName - ) -import RdrName ( RdrName, mkRdrUnqual, rdrNameOcc, nameRdrName ) -import OccName ( OccName, mkClassTyConOcc, mkClassDataConOcc, - mkSuperDictSelOcc, mkGenOcc1, mkGenOcc2, - mkDataConWrapperOcc, mkDataConWorkerOcc ) -import TyCon ( DataConDetails(..) ) -import SrcLoc ( noSrcLoc, mkSrcLoc ) -import Maybes ( maybeToBool ) -import StringBuffer ( hGetStringBuffer ) -import FastString ( mkFastString ) -import ErrUtils ( Message ) -import Finder ( findModule, findPackageModule, - hiBootExt, hiBootVerExt ) -import Lexer -import FiniteMap -import ListSetOps ( minusList ) -import Outputable -import Bag -import BinIface ( readBinIface ) -import Panic - -import EXCEPTION as Exception -import DATA_IOREF ( readIORef ) - -import Directory -\end{code} - - -%********************************************************* -%* * -\subsection{Loading a new interface file} -%* * -%********************************************************* - -\begin{code} -loadHomeInterface :: SDoc -> Name -> TcRn m ModIface -loadHomeInterface doc_str name - = ASSERT2( not (isInternalName name), ppr name <+> parens doc_str ) - loadInterface doc_str (moduleName (nameModule name)) ImportBySystem - -loadOrphanModules :: [ModuleName] -> TcRn m () -loadOrphanModules mods - | null mods = returnM () - | otherwise = traceRn (text "Loading orphan modules:" <+> - fsep (map ppr mods)) `thenM_` - mappM_ load mods `thenM_` - returnM () - where - load mod = loadInterface (mk_doc mod) mod ImportBySystem - mk_doc mod = ppr mod <+> ptext SLIT("is a orphan-instance module") - -loadInterface :: SDoc -> ModuleName -> WhereFrom -> TcRn m ModIface - -- Returns Nothing if failed - -- If we can't find an interface file, and we are doing ImportForUsage, - -- just fail in the monad, and modify anything else - -- Otherwise, if we can't find an interface file, - -- add an error message to the monad (the first time only) - -- and return emptyIface - -- The "first time only" part is done by modifying the PackageIfaceTable - -- to have an empty entry - -- - -- The ImportForUsage case is because when we read the usage information from - -- an interface file, we try to read the interfaces it mentions. - -- But it's OK to fail; perhaps the module has changed, and that interface - -- is no longer used. - -loadInterface doc_str mod_name from - = getHpt `thenM` \ hpt -> - getModule `thenM` \ this_mod -> - getImports `thenM` \ import_avails -> - getEps `thenM` \ eps@(EPS { eps_PIT = pit }) -> - - -- CHECK WHETHER WE HAVE IT ALREADY - case lookupIfaceByModName hpt pit mod_name of { - Just iface | case from of - ImportByUser src_imp -> src_imp == mi_boot iface - ImportForUsage src_imp -> src_imp == mi_boot iface - ImportBySystem -> True - -> returnM iface ; -- Already loaded - -- The not (mi_boot iface) test checks that the already-loaded - -- interface isn't a boot iface. This can conceivably happen, - -- if the version checking happened to load a boot interface - -- before we got to real imports. - other -> - - let - mod_map = imp_dep_mods import_avails - mod_info = lookupModuleEnvByName mod_map mod_name - - hi_boot_file - = case (from, mod_info) of - (ImportByUser is_boot, _) -> is_boot - (ImportForUsage is_boot, _) -> is_boot - (ImportBySystem, Just (_, is_boot)) -> is_boot - (ImportBySystem, Nothing) -> False - -- We're importing a module we know absolutely - -- nothing about, so we assume it's from - -- another package, where we aren't doing - -- dependency tracking. So it won't be a hi-boot file. - - redundant_source_import - = case (from, mod_info) of - (ImportByUser True, Just (_, False)) -> True - other -> False - in - - -- Issue a warning for a redundant {- SOURCE -} import - -- NB that we arrange to read all the ordinary imports before - -- any of the {- SOURCE -} imports - warnIf redundant_source_import - (warnRedundantSourceImport mod_name) `thenM_` - - -- Check that we aren't importing ourselves. - -- That only happens in Rename.checkOldIface, - -- which doesn't call loadInterface - warnIf - (isHomeModule this_mod && moduleName this_mod == mod_name) - (warnSelfImport this_mod) `thenM_` - - -- READ THE MODULE IN - findAndReadIface doc_str mod_name hi_boot_file - `thenM` \ read_result -> - case read_result of { - Left err - | case from of { ImportForUsage _ -> True ; other -> False } - -> failM -- Fail with no error messages - - | otherwise - -> let -- Not found, so add an empty export env to - -- the EPS map so that we don't look again - fake_mod = mkPackageModule mod_name - fake_iface = emptyModIface fake_mod - new_eps = eps { eps_PIT = extendModuleEnv pit fake_mod fake_iface } - in - setEps new_eps `thenM_` - addErr (elaborate err) `thenM_` - returnM fake_iface - where - elaborate err = hang (ptext SLIT("Failed to load interface for") <+> - quotes (ppr mod_name) <> colon) 4 err - ; - - -- Found and parsed! - Right (mod, iface) -> - - -- LOAD IT INTO EPS - - -- NB: *first* we do loadDecl, so that the provenance of all the locally-defined - --- names is done correctly (notably, whether this is an .hi file or .hi-boot file). - -- If we do loadExport first the wrong info gets into the cache (unless we - -- explicitly tag each export which seems a bit of a bore) - - - -- Sanity check. If we're system-importing a module we know nothing at all - -- about, it should be from a different package to this one - WARN( not (maybeToBool mod_info) && - case from of { ImportBySystem -> True; other -> False } && - isHomeModule mod, - ppr mod ) - - initRn (InterfaceMode mod) $ - -- Set the module, for use when looking up occurrences - -- of names in interface decls and rules - loadDecls mod (eps_decls eps) (pi_decls iface) `thenM` \ (decls_vers, new_decls) -> - loadRules mod (eps_rules eps) (pi_rules iface) `thenM` \ (rule_vers, new_rules) -> - loadInstDecls mod (eps_insts eps) (pi_insts iface) `thenM` \ new_insts -> - loadExports (pi_exports iface) `thenM` \ (export_vers, avails) -> - loadFixDecls (pi_fixity iface) `thenM` \ fix_env -> - loadDeprecs (pi_deprecs iface) `thenM` \ deprec_env -> - let - version = VersionInfo { vers_module = pi_vers iface, - vers_exports = export_vers, - vers_rules = rule_vers, - vers_decls = decls_vers } - - -- Now add info about this module to the PIT - -- Even home modules loaded by this route (which only - -- happens in OneShot mode) are put in the PIT - has_orphans = pi_orphan iface - new_pit = extendModuleEnv pit mod mod_iface - mod_iface = ModIface { mi_module = mod, mi_package = pi_pkg iface, - mi_version = version, - mi_orphan = has_orphans, mi_boot = hi_boot_file, - mi_exports = avails, - mi_fixities = fix_env, mi_deprecs = deprec_env, - mi_deps = pi_deps iface, - mi_usages = panic "No mi_usages in PIT", - mi_decls = panic "No mi_decls in PIT", - mi_globals = Nothing - } - - new_eps = eps { eps_PIT = new_pit, - eps_decls = new_decls, - eps_insts = new_insts, - eps_rules = new_rules } - in - setEps new_eps `thenM_` - returnM mod_iface - }} - ------------------------------------------------------ --- Loading the export list ------------------------------------------------------ - -loadExports :: (Version, [RdrExportItem]) -> TcRn m (Version, [(ModuleName,Avails)]) -loadExports (vers, items) - = mappM loadExport items `thenM` \ avails_s -> - returnM (vers, avails_s) - - -loadExport :: RdrExportItem -> TcRn m (ModuleName, Avails) -loadExport (mod, entities) - = mappM (load_entity mod) entities `thenM` \ avails -> - returnM (mod, avails) - where - load_entity mod (Avail occ) - = newGlobalName2 mod occ `thenM` \ name -> - returnM (Avail name) - load_entity mod (AvailTC occ occs) - = newGlobalName2 mod occ `thenM` \ name -> - mappM (newGlobalName2 mod) occs `thenM` \ names -> - returnM (AvailTC name names) - - ------------------------------------------------------ --- Loading type/class/value decls ------------------------------------------------------ - -loadDecls :: Module - -> DeclsMap - -> [(Version, RdrNameTyClDecl)] - -> TcRn m (NameEnv Version, DeclsMap) -loadDecls mod (decls_map, n_slurped) decls - = foldlM (loadDecl mod) (emptyNameEnv, decls_map) decls `thenM` \ (vers, decls_map') -> - returnM (vers, (decls_map', n_slurped)) - -loadDecl mod (version_map, decls_map) (version, decl) - = maybeStripPragmas decl `thenM` \ decl -> - getTyClDeclBinders mod decl `thenM` \ avail -> - getSysBinders mod decl `thenM` \ sys_names -> - let - full_avail = case avail of - Avail n -> avail - AvailTC n ns -> AvailTC n (sys_names ++ ns) - main_name = availName full_avail - new_decls_map = extendNameEnvList decls_map stuff - stuff = [ (name, (full_avail, name==main_name, (mod, decl))) - | name <- availNames full_avail] - - new_version_map = extendNameEnv version_map main_name version - in --- traceRn (text "Loading" <+> ppr full_avail) `thenM_` - returnM (new_version_map, new_decls_map) - -maybeStripPragmas sig@(IfaceSig {tcdIdInfo = idinfo}) - = doptM Opt_IgnoreInterfacePragmas `thenM` \ ignore_prags -> - if ignore_prags - then returnM sig{ tcdIdInfo = [] } - else returnM sig -maybeStripPragmas other - = returnM other - ------------------ -getTyClDeclBinders :: Module -> RdrNameTyClDecl -> TcRn m AvailInfo - -getTyClDeclBinders mod (IfaceSig {tcdName = var, tcdLoc = src_loc}) - = newTopBinder mod var src_loc `thenM` \ var_name -> - returnM (Avail var_name) - -getTyClDeclBinders mod tycl_decl - = mapM new (tyClDeclNames tycl_decl) `thenM` \ names@(main_name:_) -> - returnM (AvailTC main_name names) - where - new (nm,loc) = newTopBinder mod nm loc - --------------------------------- --- The "system names" are extra implicit names *bound* by the decl. - -getSysBinders :: Module -> TyClDecl RdrName -> TcRn m [Name] --- Similar to tyClDeclNames, but returns the "implicit" --- or "system" names of the declaration. And it only works --- on RdrNames, returning OccNames - -getSysBinders mod (ClassDecl {tcdName = cname, tcdCtxt = cxt, tcdLoc = loc}) - = mapM (new_sys_bndr mod loc) sys_occs - where - -- C.f. TcClassDcl.tcClassDecl1 - sys_occs = tc_occ : data_occ : dwrap_occ : dwork_occ : sc_sel_occs - cls_occ = rdrNameOcc cname - data_occ = mkClassDataConOcc cls_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]] - -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 - = 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 = [] - 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 loc occ = newTopBinder mod (mkRdrUnqual occ) loc - - ------------------------------------------------------ --- Loading fixity decls ------------------------------------------------------ - -loadFixDecls decls - = mappM loadFixDecl decls `thenM` \ to_add -> - returnM (mkNameEnv to_add) - -loadFixDecl (FixitySig rdr_name fixity loc) - = lookupGlobalOccRn rdr_name `thenM` \ name -> - returnM (name, FixitySig name fixity loc) - - ------------------------------------------------------ --- Loading instance decls ------------------------------------------------------ - -loadInstDecls :: Module -> IfaceInsts - -> [RdrNameInstDecl] - -> RnM IfaceInsts -loadInstDecls mod (insts, n_slurped) decls - = foldlM (loadInstDecl mod) insts decls `thenM` \ insts' -> - returnM (insts', n_slurped) - - -loadInstDecl mod insts decl@(InstDecl inst_ty _ _ _ _) - = -- Find out what type constructors and classes are "gates" for the - -- instance declaration. If all these "gates" are slurped in then - -- we should slurp the instance decl too. - -- - -- We *don't* want to count names in the context part as gates, though. - -- For example: - -- instance Foo a => Baz (T a) where ... - -- - -- Here the gates are Baz and T, but *not* Foo. - -- - -- HOWEVER: functional dependencies make things more complicated - -- class C a b | a->b where ... - -- instance C Foo Baz where ... - -- Here, the gates are really only C and Foo, *not* Baz. - -- That is, if C and Foo are visible, even if Baz isn't, we must - -- slurp the decl. - -- - -- Rather than take fundeps into account "properly", we just slurp - -- if C is visible and *any one* of the Names in the types - -- This is a slightly brutal approximation, but most instance decls - -- are regular H98 ones and it's perfect for them. - -- - -- NOTICE that we rename the type before extracting its free - -- variables. The free-variable finder for a renamed HsType - -- does the Right Thing for built-in syntax like [] and (,). - rnHsType (text "In an interface instance decl") inst_ty `thenM` \ inst_ty' -> - let - (tvs,_,cls,tys) = splitHsInstDeclTy inst_ty' - free_tcs = nameSetToList (extractHsTyNames_s tys) `minusList` hsTyVarNames tvs - - gate_fn vis_fn = vis_fn cls && (null free_tcs || any vis_fn free_tcs) - -- The 'vis_fn' returns True for visible names - -- Here is the implementation of HOWEVER above - -- (Note that we do let the inst decl in if it mentions - -- no tycons at all. Hence the null free_ty_names.) - in --- traceRn ((text "Load instance for" <+> ppr inst_ty') $$ ppr free_tcs) `thenM_` - returnM ((gate_fn, (mod, decl)) `consBag` insts) - - - ------------------------------------------------------ --- Loading Rules ------------------------------------------------------ - -loadRules :: Module - -> IfaceRules - -> (Version, [RdrNameRuleDecl]) - -> RnM (Version, IfaceRules) -loadRules mod (rule_bag, n_slurped) (version, rules) - = doptM Opt_IgnoreInterfacePragmas `thenM` \ ignore_prags -> - if null rules || ignore_prags - then returnM (version, (rule_bag, n_slurped)) - else mappM (loadRule mod) rules `thenM` \ new_rules -> - returnM (version, (rule_bag `unionBags` - listToBag new_rules, n_slurped)) - -loadRule :: Module -> RdrNameRuleDecl -> RnM (GatedDecl RdrNameRuleDecl) --- "Gate" the rule simply by whether the rule variable is --- needed. We can refine this later. -loadRule mod decl@(IfaceRule _ _ _ var _ _ src_loc) - = lookupGlobalOccRn var `thenM` \ var_name -> - returnM (\vis_fn -> vis_fn var_name, (mod, decl)) - - ------------------------------------------------------ --- Loading Deprecations ------------------------------------------------------ - -loadDeprecs :: IfaceDeprecs -> RnM Deprecations -loadDeprecs Nothing = returnM NoDeprecs -loadDeprecs (Just (Left txt)) = returnM (DeprecAll txt) -loadDeprecs (Just (Right prs)) = foldlM loadDeprec emptyNameEnv prs `thenM` \ env -> - returnM (DeprecSome env) -loadDeprec deprec_env (n, txt) - = lookupGlobalOccRn n `thenM` \ name -> --- traceRn (text "Loaded deprecation(s) for" <+> ppr name <> colon <+> ppr txt) `thenM_` - returnM (extendNameEnv deprec_env name (name,txt)) -\end{code} - - -%******************************************************** -%* * - Load the ParsedIface for the *current* module - into a ModIface; then it can be checked - for up-to-date-ness -%* * -%******************************************************** - -\begin{code} -loadOldIface :: ParsedIface -> RnM ModIface - -loadOldIface iface - = loadHomeDecls (pi_decls iface) `thenM` \ (decls_vers, new_decls) -> - loadHomeRules (pi_rules iface) `thenM` \ (rule_vers, new_rules) -> - loadHomeInsts (pi_insts iface) `thenM` \ new_insts -> - mappM loadHomeUsage (pi_usages iface) `thenM` \ usages -> - loadExports (pi_exports iface) `thenM` \ (export_vers, avails) -> - loadFixDecls (pi_fixity iface) `thenM` \ fix_env -> - loadDeprecs (pi_deprecs iface) `thenM` \ deprec_env -> - - getModeRn `thenM` \ (InterfaceMode mod) -> - -- Caller sets the module before the call; also needed - -- by the newGlobalName stuff in some of the loadHomeX calls - let - version = VersionInfo { vers_module = pi_vers iface, - vers_exports = export_vers, - vers_rules = rule_vers, - vers_decls = decls_vers } - - decls = mkIfaceDecls new_decls new_rules new_insts - - mod_iface = ModIface { mi_module = mod, mi_package = pi_pkg iface, - mi_version = version, mi_deps = pi_deps iface, - mi_exports = avails, mi_usages = usages, - mi_boot = False, mi_orphan = pi_orphan iface, - mi_fixities = fix_env, mi_deprecs = deprec_env, - mi_decls = decls, - mi_globals = Nothing - } - in - returnM mod_iface -\end{code} - -\begin{code} -loadHomeDecls :: [(Version, RdrNameTyClDecl)] - -> RnM (NameEnv Version, [RenamedTyClDecl]) -loadHomeDecls decls = foldlM loadHomeDecl (emptyNameEnv, []) decls - -loadHomeDecl :: (NameEnv Version, [RenamedTyClDecl]) - -> (Version, RdrNameTyClDecl) - -> RnM (NameEnv Version, [RenamedTyClDecl]) -loadHomeDecl (version_map, decls) (version, decl) - = rnTyClDecl decl `thenM` \ decl' -> - returnM (extendNameEnv version_map (tyClDeclName decl') version, decl':decls) - ------------------- -loadHomeRules :: (Version, [RdrNameRuleDecl]) - -> RnM (Version, [RenamedRuleDecl]) -loadHomeRules (version, rules) - = mappM rnIfaceRuleDecl rules `thenM` \ rules' -> - returnM (version, rules') - ------------------- -loadHomeInsts :: [RdrNameInstDecl] - -> RnM [RenamedInstDecl] -loadHomeInsts insts = mappM rnInstDecl insts - ------------------- -loadHomeUsage :: Usage OccName -> TcRn m (Usage Name) -loadHomeUsage usage - = mappM rn_imp (usg_entities usage) `thenM` \ entities' -> - returnM (usage { usg_entities = entities' }) - where - mod_name = usg_name usage - rn_imp (occ,vers) = newGlobalName2 mod_name occ `thenM` \ name -> - returnM (name,vers) -\end{code} - - -%********************************************************* -%* * -\subsection{Reading an interface file} -%* * -%********************************************************* - -\begin{code} -findAndReadIface :: SDoc -> ModuleName - -> IsBootInterface -- True <=> Look for a .hi-boot file - -- False <=> Look for .hi file - -> TcRn m (Either Message (Module, ParsedIface)) - -- Nothing <=> file not found, or unreadable, or illegible - -- Just x <=> successfully found and parsed - - -- It *doesn't* add an error to the monad, because - -- sometimes it's ok to fail... see notes with loadInterface - -findAndReadIface doc_str mod_name hi_boot_file - = traceRn trace_msg `thenM_` - - -- Check for GHC.Prim, and return its static interface - if mod_name == gHC_PRIM_Name - then returnM (Right (gHC_PRIM, ghcPrimIface)) - else - - ioToTcRn (findHiFile mod_name hi_boot_file) `thenM` \ maybe_found -> - - case maybe_found of - Left files -> - traceRn (ptext SLIT("...not found")) `thenM_` - getDOpts `thenM` \ dflags -> - returnM (Left (noIfaceErr dflags mod_name hi_boot_file files)) - - Right (wanted_mod, file_path) -> - traceRn (ptext SLIT("readIFace") <+> text file_path) `thenM_` - - readIface wanted_mod file_path hi_boot_file `thenM` \ read_result -> - -- Catch exceptions here - - case read_result of - Left exn -> returnM (Left (badIfaceFile file_path - (text (showException exn)))) - - Right iface -> returnM (Right (wanted_mod, iface)) - - where - trace_msg = sep [hsep [ptext SLIT("Reading"), - if hi_boot_file then ptext SLIT("[boot]") else empty, - ptext SLIT("interface for"), - ppr mod_name <> semi], - nest 4 (ptext SLIT("reason:") <+> doc_str)] - -findHiFile :: ModuleName -> IsBootInterface - -> IO (Either [FilePath] (Module, FilePath)) -findHiFile mod_name hi_boot_file - = do { - -- In interactive or --make mode, we are *not allowed* to demand-load - -- a home package .hi file. So don't even look for them. - -- This helps in the case where you are sitting in eg. ghc/lib/std - -- and start up GHCi - it won't complain that all the modules it tries - -- to load are found in the home location. - ghci_mode <- readIORef v_GhcMode ; - let { home_allowed = hi_boot_file || - not (isCompManagerMode ghci_mode) } ; - maybe_found <- if home_allowed - then findModule mod_name - else findPackageModule mod_name ; - - case maybe_found of { - Left files -> return (Left files) ; - - Right (mod,loc) -> do { - - -- Return the path to M.hi, M.hi-boot, or M.hi-boot-n as appropriate - let { hi_path = ml_hi_file loc ; - hi_boot_path = replaceFilenameSuffix hi_path hiBootExt ; - hi_boot_ver_path = replaceFilenameSuffix hi_path hiBootVerExt - }; - - if not hi_boot_file then - return (Right (mod, hi_path)) - else do { - hi_ver_exists <- doesFileExist hi_boot_ver_path ; - if hi_ver_exists then return (Right (mod, hi_boot_ver_path)) - else return (Right (mod, hi_boot_path)) - }}}} -\end{code} - -@readIface@ tries just the one file. - -\begin{code} -readIface :: Module -> String -> IsBootInterface -> TcRn m (Either Exception ParsedIface) - -- Nothing <=> file not found, or unreadable, or illegible - -- Just x <=> successfully found and parsed - -readIface mod file_path is_hi_boot_file - = do dflags <- getDOpts - ioToTcRn (tryMost (read_iface mod dflags file_path is_hi_boot_file)) - -read_iface mod dflags file_path is_hi_boot_file - | is_hi_boot_file -- Read ascii - = do { buffer <- hGetStringBuffer file_path ; - case unP parseIface (mkPState buffer loc dflags) of - POk _ iface | wanted_mod_name == actual_mod_name - -> return iface - | otherwise - -> throwDyn (ProgramError (showSDoc err)) - -- 'showSDoc' is a bit yukky - where - wanted_mod_name = moduleName mod - actual_mod_name = pi_mod iface - err = hiModuleNameMismatchWarn wanted_mod_name actual_mod_name - - PFailed loc1 loc2 err -> - throwDyn (ProgramError (showPFailed loc1 loc2 err)) - } - - | otherwise -- Read binary - = readBinIface file_path - - where - loc = mkSrcLoc (mkFastString file_path) 1 0 -\end{code} - - -%********************************************************* -%* * - Wired-in interface for GHC.Prim -%* * -%********************************************************* - -\begin{code} -ghcPrimIface :: ParsedIface -ghcPrimIface = ParsedIface { - pi_mod = gHC_PRIM_Name, - pi_pkg = basePackage, - pi_deps = noDependencies, - pi_vers = 1, - pi_orphan = False, - pi_usages = [], - pi_exports = (1, [(gHC_PRIM_Name, ghcPrimExports)]), - pi_decls = [], - pi_fixity = [FixitySig (nameRdrName (idName seqId)) - (Fixity 0 InfixR) noSrcLoc], - -- seq is infixr 0 - pi_insts = [], - pi_rules = (1,[]), - pi_deprecs = Nothing - } -\end{code} - -%********************************************************* -%* * -\subsection{Errors} -%* * -%********************************************************* - -\begin{code} -badIfaceFile file err - = vcat [ptext SLIT("Bad interface file:") <+> text file, - nest 4 err] - -hiModuleNameMismatchWarn :: ModuleName -> ModuleName -> Message -hiModuleNameMismatchWarn requested_mod read_mod = - hsep [ ptext SLIT("Something is amiss; requested module name") - , ppr requested_mod - , ptext SLIT("differs from name found in the interface file") - , ppr read_mod - ] - -warnRedundantSourceImport mod_name - = ptext SLIT("Unnecessary {- SOURCE -} in the import of module") - <+> quotes (ppr mod_name) - -warnSelfImport mod - = ptext SLIT("Importing my own interface: module") <+> ppr mod -\end{code} diff --git a/ghc/compiler/rename/RnHsSyn.lhs b/ghc/compiler/rename/RnHsSyn.lhs index 0d20ecf8a2..716309ddb3 100644 --- a/ghc/compiler/rename/RnHsSyn.lhs +++ b/ghc/compiler/rename/RnHsSyn.lhs @@ -9,13 +9,11 @@ module RnHsSyn where #include "HsVersions.h" import HsSyn -import HsCore -import Class ( FunDep, DefMeth(..) ) -import TyCon ( visibleDataCons, tyConName ) +import Class ( FunDep ) import TysWiredIn ( tupleTyCon, listTyCon, parrTyCon, charTyCon ) import Name ( Name, getName, isTyVarName ) import NameSet -import BasicTypes ( Boxity, FixitySig ) +import BasicTypes ( Boxity ) import Outputable \end{code} @@ -30,7 +28,6 @@ type RenamedRuleDecl = RuleDecl Name type RenamedTyClDecl = TyClDecl Name type RenamedDefaultDecl = DefaultDecl Name type RenamedForeignDecl = ForeignDecl Name -type RenamedCoreDecl = CoreDecl Name type RenamedGRHS = GRHS Name type RenamedGRHSs = GRHSs Name type RenamedHsBinds = HsBinds Name @@ -81,12 +78,10 @@ extractHsTyNames ty get (HsAppTy ty1 ty2) = get ty1 `unionNameSets` get ty2 get (HsListTy ty) = unitNameSet listTyCon_name `unionNameSets` get ty get (HsPArrTy ty) = unitNameSet parrTyCon_name `unionNameSets` get ty - get (HsTupleTy con tys) = hsTupConFVs con `unionNameSets` extractHsTyNames_s tys + get (HsTupleTy con tys) = extractHsTyNames_s tys get (HsFunTy ty1 ty2) = get ty1 `unionNameSets` get ty2 get (HsPredTy p) = extractHsPredTyNames p - get (HsOpTy ty1 tycon ty2) = get ty1 `unionNameSets` get ty2 `unionNameSets` - case tycon of { HsTyOp n -> unitNameSet n ; - HsArrow -> emptyNameSet } + get (HsOpTy ty1 op ty2) = get ty1 `unionNameSets` get ty2 `unionNameSets` unitNameSet op get (HsParTy ty) = get ty get (HsNumTy n) = emptyNameSet get (HsTyVar tv) = unitNameSet tv @@ -129,67 +124,14 @@ In all cases this is set up for interface-file declarations: \begin{code} ---------------- -impDeclFVs :: RenamedHsDecl -> NameSet - -- Just the ones that come from imports -impDeclFVs (InstD d) = instDeclFVs d -impDeclFVs (TyClD d) = tyClDeclFVs d - ----------------- -tyClDeclFVs :: RenamedTyClDecl -> NameSet -tyClDeclFVs (ForeignType {}) - = emptyFVs - -tyClDeclFVs (IfaceSig {tcdType = ty, tcdIdInfo = id_infos}) - = extractHsTyNames ty `plusFV` - plusFVs (map hsIdInfoFVs id_infos) - -tyClDeclFVs (TyData {tcdCtxt = context, tcdTyVars = tyvars, tcdCons = condecls}) - = delFVs (map hsTyVarName tyvars) $ - extractHsCtxtTyNames context `plusFV` - plusFVs (map conDeclFVs (visibleDataCons condecls)) - -tyClDeclFVs (TySynonym {tcdTyVars = tyvars, tcdSynRhs = ty}) - = delFVs (map hsTyVarName tyvars) (extractHsTyNames ty) - -tyClDeclFVs (ClassDecl {tcdCtxt = context, tcdTyVars = tyvars, tcdFDs = fds, - tcdSigs = sigs, tcdMeths = maybe_meths}) - = delFVs (map hsTyVarName tyvars) $ - extractHsCtxtTyNames context `plusFV` - plusFVs (map extractFunDepNames fds) `plusFV` - hsSigsFVs sigs `plusFV` - dm_fvs - where - dm_fvs = case maybe_meths of - Nothing -> mkFVs [v | ClassOpSig _ (DefMeth v) _ _ <- sigs] - -- No method bindings, so this class decl comes from an interface file, - -- So we want to treat the default-method names as free (they should - -- be defined somewhere else). [In source code this is not so; the class - -- decl will bind whatever default-methods are necessary.] - Just _ -> emptyFVs -- Source code, so the default methods - -- are *bound* not *free* - ----------------- hsSigsFVs sigs = plusFVs (map hsSigFVs sigs) hsSigFVs (Sig v ty _) = extractHsTyNames ty hsSigFVs (SpecInstSig ty _) = extractHsTyNames ty hsSigFVs (SpecSig v ty _) = extractHsTyNames ty -hsSigFVs (ClassOpSig _ _ ty _) = extractHsTyNames ty hsSigFVs other = emptyFVs ---------------- -instDeclFVs (InstDecl inst_ty _ _ maybe_dfun _) - = extractHsTyNames inst_ty `plusFV` - (case maybe_dfun of { Just n -> unitFV n; Nothing -> emptyFVs }) - ----------------- -ruleDeclFVs (HsRule _ _ _ _ _ _) = emptyFVs -ruleDeclFVs (IfaceRuleOut _ _) = emptyFVs -ruleDeclFVs (IfaceRule _ _ vars _ args rhs _) - = delFVs (map ufBinderName vars) $ - ufExprFVs rhs `plusFV` plusFVs (map ufExprFVs args) - ----------------- conDeclFVs (ConDecl _ tyvars context details _) = delFVs (map hsTyVarName tyvars) $ extractHsCtxtTyNames context `plusFV` @@ -200,41 +142,6 @@ conDetailsFVs (InfixCon bty1 bty2) = bangTyFVs bty1 `plusFV` bangTyFVs bty2 conDetailsFVs (RecCon flds) = plusFVs [bangTyFVs bty | (_, bty) <- flds] bangTyFVs bty = extractHsTyNames (getBangType bty) - ----------------- -hsIdInfoFVs (HsUnfold _ unf) = ufExprFVs unf -hsIdInfoFVs (HsWorker n a) = unitFV n -hsIdInfoFVs other = emptyFVs - ----------------- -ufExprFVs (UfVar n) = unitFV n -ufExprFVs (UfLit l) = emptyFVs -ufExprFVs (UfFCall cc ty) = extractHsTyNames ty -ufExprFVs (UfType ty) = extractHsTyNames ty -ufExprFVs (UfTuple tc es) = hsTupConFVs tc `plusFV` plusFVs (map ufExprFVs es) -ufExprFVs (UfLam v e) = ufBndrFVs v (ufExprFVs e) -ufExprFVs (UfApp e1 e2) = ufExprFVs e1 `plusFV` ufExprFVs e2 -ufExprFVs (UfCase e n as) = ufExprFVs e `plusFV` delFV n (plusFVs (map ufAltFVs as)) -ufExprFVs (UfNote n e) = ufNoteFVs n `plusFV` ufExprFVs e -ufExprFVs (UfLet (UfNonRec b r) e) = ufExprFVs r `plusFV` ufBndrFVs b (ufExprFVs e) -ufExprFVs (UfLet (UfRec prs) e) = foldr ufBndrFVs - (foldr (plusFV . ufExprFVs . snd) (ufExprFVs e) prs) - (map fst prs) - -ufBndrFVs (UfValBinder n ty) fvs = extractHsTyNames ty `plusFV` delFV n fvs -ufBndrFVs (UfTyBinder n k) fvs = delFV n fvs - -ufAltFVs (con, vs, e) = ufConFVs con `plusFV` delFVs vs (ufExprFVs e) - -ufConFVs (UfDataAlt n) = unitFV n -ufConFVs (UfTupleAlt t) = hsTupConFVs t -ufConFVs other = emptyFVs - -ufNoteFVs (UfCoerce ty) = extractHsTyNames ty -ufNoteFVs note = emptyFVs - -hsTupConFVs (HsTupCon bx n) = unitFV (tyConName (tupleTyCon bx n)) - -- Always return the TyCon; that'll suck in the data con \end{code} diff --git a/ghc/compiler/rename/RnIfaces.lhs b/ghc/compiler/rename/RnIfaces.lhs deleted file mode 100644 index 81a2990961..0000000000 --- a/ghc/compiler/rename/RnIfaces.lhs +++ /dev/null @@ -1,731 +0,0 @@ -% -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 -section -\%[RnIfaces]{Cacheing and Renaming of Interfaces} - -\begin{code} -module RnIfaces - ( slurpImpDecls, importSupportingDecls, - RecompileRequired, outOfDate, upToDate, checkVersions - ) -where - -#include "HsVersions.h" - -import CmdLineOpts ( DynFlag(..), opt_NoPruneDecls ) -import HscTypes -import HsSyn ( HsDecl(..), Sig(..), TyClDecl(..), ConDecl(..), HsConDetails(..), - InstDecl(..), HsType(..), hsTyVarNames, getBangType - ) -import RdrHsSyn ( RdrNameTyClDecl, RdrNameInstDecl, RdrNameRuleDecl ) -import RnHsSyn ( RenamedHsDecl, RenamedTyClDecl, - extractHsTyNames, extractHsCtxtTyNames, - tyClDeclFVs, ruleDeclFVs, impDeclFVs - ) -import RnHiFiles ( loadInterface, loadHomeInterface, loadOrphanModules ) -import RnNames ( mkModDeps ) -import RnSource ( rnTyClDecl, rnInstDecl, rnIfaceRuleDecl ) -import TcEnv ( getInGlobalScope, tcLookupGlobal_maybe ) -import TcRnMonad -import Id ( idType, idName, globalIdDetails ) -import IdInfo ( GlobalIdDetails(..) ) -import TcType ( tyClsNamesOfType, classNamesOfTheta ) -import FieldLabel ( fieldLabelTyCon ) -import DataCon ( dataConTyCon, dataConWrapId ) -import TyCon ( visibleDataCons, isSynTyCon, getSynTyConDefn, tyConClass_maybe, tyConName ) -import Class ( className, classSCTheta ) -import Name ( Name {-instance NamedThing-}, isWiredInName, nameIsLocalOrFrom, - nameModule, NamedThing(..) ) -import NameEnv ( delFromNameEnv, lookupNameEnv ) -import NameSet -import Module ( Module, isHomeModule ) -import PrelNames ( hasKey, fractionalClassKey, numClassKey, - integerTyConName, doubleTyConName ) -import Outputable -import Bag -import Maybe( fromJust ) -\end{code} - - -%********************************************************* -%* * -\subsection{Slurping declarations} -%* * -%********************************************************* - -\begin{code} -------------------------------------------------------- -slurpImpDecls :: FreeVars -> TcRn m [RenamedHsDecl] -slurpImpDecls source_fvs - = traceRn (text "slurpImp" <+> fsep (map ppr (nameSetToList source_fvs))) `thenM_` - - -- Slurp in things which might be 'gates' for instance - -- declarations, plus the instance declarations themselves - slurpSourceRefs source_fvs `thenM` \ (gate_decls, bndrs) -> - - -- Then get everything else - let - needed = foldr (plusFV . impDeclFVs) emptyFVs gate_decls - in - import_supporting_decls (gate_decls, bndrs) needed - - -------------------------------------------------------- -slurpSourceRefs :: FreeVars -- Variables referenced in source - -> TcRn m ([RenamedHsDecl], -- Needed declarations - NameSet) -- Names bound by those declarations --- Slurp imported declarations needed directly by the source code; --- and some of the ones they need. The goal is to find all the 'gates' --- for instance declarations. - -slurpSourceRefs source_fvs - = go_outer [] emptyFVs -- Accumulating decls - (nameSetToList source_fvs) -- Things whose defn hasn't been loaded yet - where - -- The outer loop repeatedly slurps the decls for the current gates - -- and the instance decls - - -- The outer loop is needed because consider - -- instance Foo a => Baz (Maybe a) where ... - -- It may be that Baz and Maybe are used in the source module, - -- but not Foo; so we need to chase Foo too. - -- - -- We also need to follow superclass refs. In particular, 'chasing Foo' must - -- include actually getting in Foo's class decl - -- class Wib a => Foo a where .. - -- so that its superclasses are discovered. The point is that Wib is a gate too. - -- We do this for tycons too, so that we look through type synonyms. - - go_outer decls bndrs [] = returnM (decls, bndrs) - - go_outer decls bndrs refs -- 'refs' are not necessarily slurped yet - = traceRn (text "go_outer" <+> ppr refs) `thenM_` - foldlM go_inner (decls, bndrs, emptyFVs) refs `thenM` \ (decls1, bndrs1, gates1) -> - getImportedInstDecls gates1 `thenM` \ (inst_decls, new_gates) -> - rnIfaceDecls rnInstDecl inst_decls `thenM` \ inst_decls' -> - go_outer (map InstD inst_decls' ++ decls1) - bndrs1 - (nameSetToList (new_gates `plusFV` plusFVs (map getInstDeclGates inst_decls'))) - -- NB: we go round again to fetch the decls for any gates of any decls - -- we have loaded. For example, if we mention - -- print :: Show a => a -> String - -- then we must load the decl for Show before stopping, to ensure - -- that instances from its home module are available - - go_inner (decls, bndrs, gates) wanted_name - = importDecl bndrs wanted_name `thenM` \ import_result -> - case import_result of - AlreadySlurped -> returnM (decls, bndrs, gates) - - InTypeEnv ty_thing - -> returnM (decls, - bndrs `addOneFV` wanted_name, -- Avoid repeated calls to getWiredInGates - gates `plusFV` getWiredInGates ty_thing) - - HereItIs decl new_bndrs - -> rnIfaceDecl rnTyClDecl decl `thenM` \ new_decl -> - returnM (TyClD new_decl : decls, - bndrs `plusFV` new_bndrs, - gates `plusFV` getGates source_fvs new_decl) -\end{code} - -\begin{code} -------------------------------------------------------- --- import_supporting_decls keeps going until the free-var set is empty -importSupportingDecls needed - = import_supporting_decls ([], emptyNameSet) needed - -import_supporting_decls - :: ([RenamedHsDecl], NameSet) -- Some imported decls, with their binders - -> FreeVars -- Remaining un-slurped names - -> TcRn m [RenamedHsDecl] -import_supporting_decls decls needed - = slurpIfaceDecls decls needed `thenM` \ (decls1, bndrs1) -> - getImportedRules bndrs1 `thenM` \ rule_decls -> - case rule_decls of - [] -> returnM decls1 -- No new rules, so we are done - other -> rnIfaceDecls rnIfaceRuleDecl rule_decls `thenM` \ rule_decls' -> - let - rule_fvs = plusFVs (map ruleDeclFVs rule_decls') - decls2 = decls1 ++ map RuleD rule_decls' - in - traceRn (text "closeRules" <+> ppr rule_decls' $$ - fsep (map ppr (nameSetToList rule_fvs))) `thenM_` - import_supporting_decls (decls2, bndrs1) rule_fvs - - -------------------------------------------------------- --- Augment decls with any decls needed by needed, --- and so on transitively -slurpIfaceDecls :: ([RenamedHsDecl], NameSet) -- Already slurped - -> FreeVars -- Still needed - -> TcRn m ([RenamedHsDecl], NameSet) -slurpIfaceDecls (decls, bndrs) needed - = slurp decls bndrs (nameSetToList needed) - where - slurp decls bndrs [] = returnM (decls, bndrs) - slurp decls bndrs (n:ns) - = importDecl bndrs n `thenM` \ import_result -> - case import_result of - HereItIs decl new_bndrs -- Found a declaration... rename it - -> rnIfaceDecl rnTyClDecl decl `thenM` \ new_decl -> - slurp (TyClD new_decl : decls) - (bndrs `plusFV` new_bndrs) - (nameSetToList (tyClDeclFVs new_decl) ++ ns) - - - other -> -- No declaration... (wired in thing, or deferred, - -- or already slurped) - slurp decls (bndrs `addOneFV` n) ns - -------------------------------------------------------- -rnIfaceDecls rn decls = mappM (rnIfaceDecl rn) decls -rnIfaceDecl rn (mod, decl) = initRn (InterfaceMode mod) (rn decl) -\end{code} - - -\begin{code} - -- 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 (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 - DataConWorkId dc -> get_main_name (ATyCon (dataConTyCon dc)) - DataConWrapId dc -> get_main_name (ATyCon (dataConTyCon dc)) - RecordSelId lbl -> get_main_name (ATyCon (fieldLabelTyCon lbl)) - GenericOpId tc -> get_main_name (ATyCon tc) - ClassOpId cl -> className cl - other -> idName id - - -recordUsage :: Name -> TcRn m () --- Record that the Name has been used, for --- later generation of usage info in the interface file -recordUsage name = updUsages (upd_usg name) - -upd_usg name usages - | isHomeModule mod = addOneToNameSet usages name - | otherwise = usages - where - mod = nameModule name -\end{code} - - -%********************************************************* -%* * -\subsection{Getting in a declaration} -%* * -%********************************************************* - -\begin{code} -importDecl :: NameSet -> Name -> TcRn m ImportDeclResult - -data ImportDeclResult - = AlreadySlurped - | InTypeEnv TyThing - | HereItIs (Module, RdrNameTyClDecl) NameSet - -- The NameSet is the bunch of names bound by this decl - -importDecl already_slurped name - = -- STEP 0: Check if it's from this module - -- Doing this catches a common case quickly - getModule `thenM` \ this_mod -> - if nameIsLocalOrFrom this_mod name then - -- Variables defined on the GHCi command line (e.g. let x = 3) - -- are Internal names (which don't have a Module) - returnM AlreadySlurped - else - - -- STEP 1: Check if we've slurped it in while compiling this module - if name `elemNameSet` already_slurped then - returnM AlreadySlurped - else - - -- STEP 2: Check if it's already in the type environment - tcLookupGlobal_maybe name `thenM` \ maybe_thing -> - case maybe_thing of { - - Just ty_thing - | isWiredInName name - -> -- When we find a wired-in name we must load its home - -- module so that we find any instance decls lurking therein - loadHomeInterface wi_doc name `thenM_` - returnM (InTypeEnv ty_thing) - - | otherwise - -> -- We have slurp something that's already in the type environment, - -- that was not slurped in an earlier compilation. - -- Must still record it in the Usages info, because that's used to - -- generate usage information - - traceRn (text "not wired in" <+> ppr name) `thenM_` - recordUsage (get_main_name ty_thing) `thenM_` - returnM (InTypeEnv ty_thing) ; - - Nothing -> - - -- STEP 4: OK, we have to slurp it in from an interface file - -- First load the interface file - traceRn nd_doc `thenM_` - loadHomeInterface nd_doc name `thenM_` - - -- STEP 4: Get the declaration out - getEps `thenM` \ eps -> - let - (decls_map, n_slurped) = eps_decls eps - in - case lookupNameEnv decls_map name of - Just (avail,_,decl) -> setEps eps' `thenM_` - recordUsage (availName avail) `thenM_` - returnM (HereItIs decl (mkFVs avail_names)) - where - avail_names = availNames avail - new_decls_map = foldl delFromNameEnv decls_map avail_names - eps' = eps { eps_decls = (new_decls_map, n_slurped+1) } - - Nothing -> addErr (getDeclErr name) `thenM_` - returnM AlreadySlurped - } - where - wi_doc = ptext SLIT("need home module for wired in thing") <+> ppr name - nd_doc = ptext SLIT("need decl for") <+> ppr name - -\end{code} - - -%********************************************************* -%* * -\subsection{Extracting the `gates'} -%* * -%********************************************************* - -The gating story -~~~~~~~~~~~~~~~~~ -We want to avoid sucking in too many instance declarations. -An instance decl is only useful if the types and classes mentioned in -its 'head' are all available in the program being compiled. E.g. - - instance (..) => C (T1 a) (T2 b) where ... - -is only useful if C, T1 and T2 are all "available". So we keep -instance decls that have been parsed from .hi files, but not yet -slurped in, in a pool called the 'gated instance pool'. -Each has its set of 'gates': {C, T1, T2} in the above example. - -More precisely, the gates of a module are the types and classes -that are mentioned in: - - a) the source code [Note: in fact these don't seem - to be treated as gates, perhaps - because no imported instance decl - can mention them; mutter mutter - recursive modules.] - b) the type of an Id that's mentioned in the source code - [includes constructors and selectors] - c) the RHS of a type synonym that is a gate - d) the superclasses of a class that is a gate - e) the context of an instance decl that is slurped in - -We slurp in an instance decl from the gated instance pool iff - - all its gates are either in the gates of the module, - or the gates of a previously-loaded module - -The latter constraint is because there might have been an instance -decl slurped in during an earlier compilation, like this: - - instance Foo a => Baz (Maybe a) where ... - -In the module being compiled we might need (Baz (Maybe T)), where T is -defined in this module, and hence we need the instance for (Foo T). -So @Foo@ becomes a gate. But there's no way to 'see' that. More -generally, types might be involved as well: - - instance Foo2 S a => Baz2 a where ... - -Now we must treat S as a gate too, as well as Foo2. So the solution -we adopt is: - - we simply treat the gates of all previously-loaded - modules as gates of this one - -So the gates are remembered across invocations of the renamer in the -PersistentRenamerState. This gloss mainly affects ghc --make and ghc ---interactive. - -(We used to use the persistent type environment for this purpose, -but it has too much. For a start, it contains all tuple types, -because they are in the wired-in type env!) - - -Consructors and class operations -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When we import a declaration like - - data T = T1 Wibble | T2 Wobble - -we don't want to treat @Wibble@ and @Wobble@ as gates {\em unless} -@T1@, @T2@ respectively are mentioned by the user program. If only -@T@ is mentioned we want only @T@ to be a gate; that way we don't suck -in useless instance decls for (say) @Eq Wibble@, when they can't -possibly be useful. - -And that's just what (b) says: we only treat T1's type as a gate if -T1 is mentioned. getGates, which deals with decls we are slurping in, -has to be a bit careful, because a mention of T1 will slurp in T's whole -declaration. - ------------------------------ -@getGates@ takes a newly imported (and renamed) decl, and the free -vars of the source program, and extracts from the decl the gate names. - -\begin{code} -getGates :: FreeVars -- Things mentioned in the source program - -- Used for the cunning "constructors and - -- class ops" story described 10 lines above. - -> RenamedTyClDecl - -> FreeVars - -getGates source_fvs decl - = get_gates (\n -> n `elemNameSet` source_fvs) decl - -get_gates is_used (ForeignType {tcdName = tycon}) = unitNameSet tycon -get_gates is_used (IfaceSig {tcdType = ty}) = extractHsTyNames ty - -get_gates is_used (ClassDecl { tcdCtxt = ctxt, tcdName = cls, tcdTyVars = tvs, tcdSigs = sigs}) - = (super_cls_and_sigs `addOneToNameSet` cls) `unionNameSets` - implicitClassGates cls - where - super_cls_and_sigs = delListFromNameSet (foldr (plusFV . get) (extractHsCtxtTyNames ctxt) sigs) - (hsTyVarNames tvs) - get (ClassOpSig n _ ty _) - | is_used n = extractHsTyNames ty - | otherwise = emptyFVs - -get_gates is_used (TySynonym {tcdTyVars = tvs, tcdSynRhs = ty}) - = delListFromNameSet (extractHsTyNames ty) (hsTyVarNames tvs) - -- A type synonym type constructor isn't a "gate" for instance decls - -get_gates is_used (TyData {tcdCtxt = ctxt, tcdName = tycon, tcdTyVars = tvs, tcdCons = cons}) - = delListFromNameSet (foldr (plusFV . get) (extractHsCtxtTyNames ctxt) - (visibleDataCons cons)) - (hsTyVarNames tvs) - `addOneToNameSet` tycon - where - get (ConDecl n tvs ctxt details _) - | is_used n - -- If the constructor is method, get fvs from all its fields - = delListFromNameSet (get_details details `plusFV` - extractHsCtxtTyNames ctxt) - (hsTyVarNames tvs) - get (ConDecl n tvs ctxt (RecCon fields) _) - -- Even if the constructor isn't mentioned, the fields - -- might be, as selectors. They can't mention existentially - -- bound tyvars (typechecker checks for that) so no need for - -- the deleteListFromNameSet part - = foldr (plusFV . get_field) emptyFVs fields - - get other_con = emptyFVs - - get_details (PrefixCon tys) = plusFVs (map get_bang tys) - get_details (InfixCon t1 t2) = get_bang t1 `plusFV` get_bang t2 - get_details (RecCon fields) = plusFVs [get_bang t | (_, t) <- fields] - - get_field (f,t) | is_used f = get_bang t - | otherwise = emptyFVs - - get_bang bty = extractHsTyNames (getBangType bty) - -implicitClassGates :: Name -> FreeVars -implicitClassGates cls - -- If we load class Num, add Integer to the free gates - -- This takes account of the fact that Integer might be needed for - -- defaulting, but we don't want to load Integer (and all its baggage) - -- if there's no numeric stuff needed. - -- Similarly for class Fractional and Double - -- - -- NB: adding T to the gates will force T to be loaded - -- - -- NB: If we load (say) Floating, we'll end up loading Fractional too, - -- since Fractional is a superclass of Floating - | cls `hasKey` numClassKey = unitFV integerTyConName - | cls `hasKey` fractionalClassKey = unitFV doubleTyConName - | otherwise = emptyFVs -\end{code} - -@getWiredInGates@ is just like @getGates@, but it sees a previously-loaded -thing rather than a declaration. - -\begin{code} -getWiredInGates :: TyThing -> FreeVars --- The TyThing is one that we already have in our type environment, either --- a) because the TyCon or Id is wired in, or --- b) from a previous compile --- --- Either way, we might have instance decls in the (persistent) collection --- of parsed-but-not-slurped instance decls that should be slurped in. --- This might be the first module that mentions both the type and the class --- for that instance decl, even though both the type and the class were --- mentioned in other modules, and hence are in the type environment - -getWiredInGates (AClass cl) - = unitFV (getName cl) `plusFV` mkFVs super_classes - where - super_classes = classNamesOfTheta (classSCTheta cl) - -getWiredInGates (AnId the_id) = tyClsNamesOfType (idType the_id) -getWiredInGates (ADataCon dc) = tyClsNamesOfType (idType (dataConWrapId dc)) - -- Should include classes in the 'stupid context' of the data con? -getWiredInGates (ATyCon tc) - | isSynTyCon tc = tyClsNamesOfType ty - | otherwise = unitFV (getName tc) - where - (_,ty) = getSynTyConDefn tc - -getInstDeclGates (InstDecl inst_ty _ _ _ _) = extractHsTyNames inst_ty -\end{code} - -\begin{code} -getImportedInstDecls :: NameSet -> TcRn m ([(Module,RdrNameInstDecl)], NameSet) - -- Returns the gates that are new since last time -getImportedInstDecls gates - = -- First, load any orphan-instance modules that aren't aready loaded - -- Orphan-instance modules are recorded in the module dependecnies - getImports `thenM` \ imports -> - getEps `thenM` \ eps -> - let - old_gates = eps_inst_gates eps - new_gates = gates `minusNameSet` old_gates - all_gates = new_gates `unionNameSets` old_gates - orphan_mods = imp_orphs imports - in - loadOrphanModules orphan_mods `thenM_` - - -- Now we're ready to grab the instance declarations - -- Find the un-gated ones and return them, - -- removing them from the bag kept in EPS - -- Don't foget to get the EPS a second time... - -- loadOrphanModules may have side-effected it! - getEps `thenM` \ eps -> - let - available n = n `elemNameSet` all_gates - (decls, new_insts) = selectGated available (eps_insts eps) - in - setEps (eps { eps_insts = new_insts, - eps_inst_gates = all_gates }) `thenM_` - - traceRn (sep [text "getImportedInstDecls:", - nest 4 (fsep (map ppr (nameSetToList gates))), - nest 4 (fsep (map ppr (nameSetToList all_gates))), - nest 4 (fsep (map ppr (nameSetToList new_gates))), - text "Slurped" <+> int (length decls) <+> text "instance declarations", - nest 4 (vcat (map ppr_brief_inst_decl decls))]) `thenM_` - returnM (decls, new_gates) - -ppr_brief_inst_decl (mod, InstDecl inst_ty _ _ _ _) - = case inst_ty of - HsForAllTy _ _ tau -> ppr tau - other -> ppr inst_ty - -getImportedRules :: NameSet -- Slurped already - -> TcRn m [(Module,RdrNameRuleDecl)] -getImportedRules slurped - = doptM Opt_IgnoreInterfacePragmas `thenM` \ ignore_prags -> - if ignore_prags then returnM [] else -- ... - getEps `thenM` \ eps -> - getInGlobalScope `thenM` \ in_type_env -> - let -- Slurp rules for anything that is slurped, - -- either now, or previously - available n = n `elemNameSet` slurped || in_type_env n - (decls, new_rules) = selectGated available (eps_rules eps) - in - if null decls then - returnM [] - else - setEps (eps { eps_rules = new_rules }) `thenM_` - traceRn (sep [text "getImportedRules:", - text "Slurped" <+> int (length decls) <+> text "rules"]) `thenM_` - returnM decls - -selectGated :: (Name->Bool) -> GatedDecls d - -> ([(Module,d)], GatedDecls d) -selectGated available (decl_bag, n_slurped) - -- Select only those decls whose gates are *all* available -#ifdef DEBUG - | opt_NoPruneDecls -- Just to try the effect of not gating at all - = let - decls = foldrBag (\ (_,d) ds -> d:ds) [] decl_bag -- Grab them all - in - (decls, (emptyBag, n_slurped + length decls)) - - | otherwise -#endif - = case foldrBag select ([], emptyBag) decl_bag of - (decls, new_bag) -> (decls, (new_bag, n_slurped + length decls)) - where - select (gate_fn, decl) (yes, no) - | gate_fn available = (decl:yes, no) - | otherwise = (yes, (gate_fn,decl) `consBag` no) -\end{code} - - -%******************************************************** -%* * -\subsection{Checking usage information} -%* * -%******************************************************** - -@recompileRequired@ is called from the HscMain. It checks whether -a recompilation is required. It needs access to the persistent state, -finder, etc, because it may have to load lots of interface files to -check their versions. - -\begin{code} -type RecompileRequired = Bool -upToDate = False -- Recompile not required -outOfDate = True -- Recompile required - -checkVersions :: Bool -- True <=> source unchanged - -> ModIface -- Old interface - -> TcRn m RecompileRequired -checkVersions source_unchanged iface - | not source_unchanged - = returnM outOfDate - | otherwise - = traceHiDiffs (text "Considering whether compilation is required for" <+> - ppr (mi_module iface) <> colon) `thenM_` - - -- Source code unchanged and no errors yet... carry on - -- First put the dependent-module info in the envt, just temporarily, - -- so that when we look for interfaces we look for the right one (.hi or .hi-boot) - -- It's just temporary because either the usage check will succeed - -- (in which case we are done with this module) or it'll fail (in which - -- case we'll compile the module from scratch anyhow). - updGblEnv (\ gbl -> gbl { tcg_imports = mod_deps }) ( - checkList [checkModUsage u | u <- mi_usages iface] - ) - - where - -- This is a bit of a hack really - mod_deps = emptyImportAvails { imp_dep_mods = mkModDeps (dep_mods (mi_deps iface)) } - -checkList :: [TcRn m RecompileRequired] -> TcRn m RecompileRequired -checkList [] = returnM upToDate -checkList (check:checks) = check `thenM` \ recompile -> - if recompile then - returnM outOfDate - else - checkList checks -\end{code} - -\begin{code} -checkModUsage :: Usage Name -> TcRn m RecompileRequired --- Given the usage information extracted from the old --- M.hi file for the module being compiled, figure out --- whether M needs to be recompiled. - -checkModUsage (Usage { usg_name = mod_name, usg_mod = old_mod_vers, - usg_rules = old_rule_vers, - usg_exports = maybe_old_export_vers, - usg_entities = old_decl_vers }) - = -- Load the imported interface is possible - let - doc_str = sep [ptext SLIT("need version info for"), ppr mod_name] - in - traceHiDiffs (text "Checking usages for module" <+> ppr mod_name) `thenM_` - - tryM (loadInterface doc_str mod_name ImportBySystem) `thenM` \ mb_iface -> - - case mb_iface of { - Left exn -> (out_of_date (sep [ptext SLIT("Can't find version number for module"), - ppr mod_name])); - -- Couldn't find or parse a module mentioned in the - -- old interface file. Don't complain -- it might just be that - -- the current module doesn't need that import and it's been deleted - - Right iface -> - let - new_vers = mi_version iface - new_mod_vers = vers_module new_vers - new_decl_vers = vers_decls new_vers - new_export_vers = vers_exports new_vers - new_rule_vers = vers_rules new_vers - in - -- CHECK MODULE - checkModuleVersion old_mod_vers new_mod_vers `thenM` \ recompile -> - if not recompile then - returnM upToDate - else - - -- CHECK EXPORT LIST - if checkExportList maybe_old_export_vers new_export_vers then - out_of_date_vers (ptext SLIT(" Export list changed")) - (fromJust maybe_old_export_vers) - new_export_vers - else - - -- CHECK RULES - if old_rule_vers /= new_rule_vers then - out_of_date_vers (ptext SLIT(" Rules changed")) - old_rule_vers new_rule_vers - else - - -- CHECK ITEMS ONE BY ONE - checkList [checkEntityUsage new_decl_vers u | u <- old_decl_vers] `thenM` \ recompile -> - if recompile then - returnM outOfDate -- This one failed, so just bail out now - else - up_to_date (ptext SLIT(" Great! The bits I use are up to date")) - - } - ------------------------- -checkModuleVersion old_mod_vers new_mod_vers - | new_mod_vers == old_mod_vers - = up_to_date (ptext SLIT("Module version unchanged")) - - | otherwise - = out_of_date_vers (ptext SLIT(" Module version has changed")) - old_mod_vers new_mod_vers - ------------------------- -checkExportList Nothing new_vers = upToDate -checkExportList (Just v) new_vers = v /= new_vers - ------------------------- -checkEntityUsage new_vers (name,old_vers) - = case lookupNameEnv new_vers name of - - Nothing -> -- We used it before, but it ain't there now - out_of_date (sep [ptext SLIT("No longer exported:"), ppr name]) - - Just new_vers -- It's there, but is it up to date? - | new_vers == old_vers -> traceHiDiffs (text " Up to date" <+> ppr name <+> parens (ppr new_vers)) `thenM_` - returnM upToDate - | otherwise -> out_of_date_vers (ptext SLIT(" Out of date:") <+> ppr name) - old_vers new_vers - -up_to_date msg = traceHiDiffs msg `thenM_` returnM upToDate -out_of_date msg = traceHiDiffs msg `thenM_` returnM outOfDate -out_of_date_vers msg old_vers new_vers - = out_of_date (hsep [msg, ppr old_vers, ptext SLIT("->"), ppr new_vers]) -\end{code} - - -%********************************************************* -%* * -\subsection{Errors} -%* * -%********************************************************* - -\begin{code} -getDeclErr name - = vcat [ptext SLIT("Failed to find interface decl for") <+> quotes (ppr name), - ptext SLIT("from module") <+> quotes (ppr (nameModule name)) - ] -\end{code} diff --git a/ghc/compiler/rename/RnNames.lhs b/ghc/compiler/rename/RnNames.lhs index d1a4f016df..f394f43fdf 100644 --- a/ghc/compiler/rename/RnNames.lhs +++ b/ghc/compiler/rename/RnNames.lhs @@ -6,45 +6,46 @@ \begin{code} module RnNames ( rnImports, importsFromLocalDecls, exportsFromAvail, - reportUnusedNames, mkModDeps + reportUnusedNames, mkModDeps, exportsToAvails ) where #include "HsVersions.h" -import {-# SOURCE #-} RnHiFiles ( loadInterface ) - import CmdLineOpts ( DynFlag(..) ) - import HsSyn ( IE(..), ieName, ImportDecl(..), ForeignDecl(..), HsGroup(..), collectLocatedHsBinders, tyClDeclNames ) import RdrHsSyn ( RdrNameIE, RdrNameImportDecl, main_RDR_Unqual ) import RnEnv +import IfaceEnv ( lookupOrig, lookupImplicitOrig ) +import LoadIface ( loadSrcInterface ) import TcRnMonad import FiniteMap -import PrelNames ( pRELUDE_Name, isBuiltInSyntaxName ) -import Module ( Module, ModuleName, ModuleEnv, moduleName, +import PrelNames ( pRELUDE_Name, isBuiltInSyntaxName, isUnboundName ) +import Module ( Module, ModuleName, moduleName, moduleNameUserString, isHomeModule, - emptyModuleEnv, unitModuleEnvByName, unitModuleEnv, - lookupModuleEnvByName, extendModuleEnvByName, moduleEnvElts ) -import Name ( Name, nameSrcLoc, nameOccName, nameModule, isExternalName ) + unitModuleEnvByName, unitModuleEnv, + lookupModuleEnvByName, moduleEnvElts ) +import Name ( Name, nameSrcLoc, nameOccName, nameModuleName, + nameParent, nameParent_maybe, isExternalName ) import NameSet import NameEnv import OccName ( OccName, srcDataName, isTcOcc ) -import HscTypes ( Provenance(..), ImportReason(..), GlobalRdrEnv, - GenAvailInfo(..), AvailInfo, Avails, GhciMode(..), - IsBootInterface, - availName, availNames, availsToNameSet, - Deprecations(..), ModIface(..), Dependencies(..), - GlobalRdrElt(..), unQualInScope, isLocalGRE, pprNameProvenance +import HscTypes ( GenAvailInfo(..), AvailInfo, Avails, GhciMode(..), + IsBootInterface, IfaceExport, + availName, availNames, availsToNameSet, unQualInScope, + Deprecs(..), ModIface(..), Dependencies(..) ) -import RdrName ( RdrName, rdrNameOcc, setRdrNameSpace, lookupRdrEnv, rdrEnvToList, - emptyRdrEnv, foldRdrEnv, rdrEnvElts, mkRdrUnqual, isQual ) +import RdrName ( RdrName, rdrNameOcc, setRdrNameSpace, + GlobalRdrEnv, mkGlobalRdrEnv, GlobalRdrElt(..), + emptyGlobalRdrEnv, plusGlobalRdrEnv, globalRdrEnvElts, + unQualOK, lookupGRE_Name, + Provenance(..), ImportSpec(..), + isLocalGRE, pprNameProvenance ) import Outputable -import Maybe ( isJust, isNothing, catMaybes ) -import Maybes ( orElse ) +import Maybes ( isJust, isNothing, catMaybes, mapCatMaybes ) import ListSetOps ( removeDups ) import Util ( sortLt, notNull ) import List ( partition, insert ) @@ -61,7 +62,7 @@ import IO ( openFile, IOMode(..) ) \begin{code} rnImports :: [RdrNameImportDecl] - -> TcRn m (GlobalRdrEnv, ImportAvails) + -> RnM (GlobalRdrEnv, ImportAvails) rnImports imports = -- PROCESS IMPORT DECLS @@ -84,7 +85,7 @@ rnImports imports let (imp_gbl_envs, imp_avails) = unzip (stuff1 ++ stuff2) gbl_env :: GlobalRdrEnv - gbl_env = foldr plusGlobalRdrEnv emptyRdrEnv imp_gbl_envs + gbl_env = foldr plusGlobalRdrEnv emptyGlobalRdrEnv imp_gbl_envs all_avails :: ImportAvails all_avails = foldr plusImportAvails emptyImportAvails imp_avails @@ -119,35 +120,38 @@ preludeImportDecl loc \begin{code} importsFromImportDecl :: Module -> RdrNameImportDecl - -> TcRn m (GlobalRdrEnv, ImportAvails) + -> RnM (GlobalRdrEnv, ImportAvails) importsFromImportDecl this_mod - (ImportDecl imp_mod_name is_boot qual_only as_mod imp_spec iloc) + (ImportDecl imp_mod_name want_boot qual_only as_mod imp_details iloc) = addSrcLoc iloc $ + + -- If there's an error in loadInterface, (e.g. interface + -- file not found) we get lots of spurious errors from 'filterImports' let + this_mod_name = moduleName this_mod doc = ppr imp_mod_name <+> ptext SLIT("is directly imported") in + loadSrcInterface doc imp_mod_name want_boot `thenM` \ iface -> - -- If there's an error in loadInterface, (e.g. interface - -- file not found) we get lots of spurious errors from 'filterImports' - tryM (loadInterface doc imp_mod_name (ImportByUser is_boot)) `thenM` \ mb_iface -> + -- Compiler sanity check: if the import didn't say + -- {-# SOURCE #-} we should not get a hi-boot file + WARN( not want_boot && mi_boot iface, ppr imp_mod_name ) - case mb_iface of { - Left exn -> returnM (emptyRdrEnv, emptyImportAvails ) ; - Right iface -> + -- Issue a user warning for a redundant {- SOURCE -} import + -- NB that we arrange to read all the ordinary imports before + -- any of the {- SOURCE -} imports + warnIf (want_boot && not (mi_boot iface)) + (warnRedundantSourceImport imp_mod_name) `thenM_` let - imp_mod = mi_module iface - avails_by_module = mi_exports iface - deprecs = mi_deprecs iface - is_orph = mi_orphan iface - deps = mi_deps iface - - avails :: Avails - avails = [ avail | (mod_name, avails) <- avails_by_module, - mod_name /= this_mod_name, - avail <- avails ] - this_mod_name = moduleName this_mod + imp_mod = mi_module iface + deprecs = mi_deprecs iface + is_orph = mi_orphan iface + deps = mi_deps iface + + filtered_exports = filter not_this_mod (mi_exports iface) + not_this_mod (mod,_) = mod /= this_mod_name -- If the module exports anything defined in this module, just ignore it. -- Reason: otherwise it looks as if there are two local definition sites -- for the thing, and an error gets reported. Easiest thing is just to @@ -164,10 +168,11 @@ importsFromImportDecl this_mod -- import {-# SOURCE #-} A( AType ) -- -- then you'll get a 'B does not export AType' message. Oh well. - in + exportsToAvails filtered_exports `thenM` \ avails -> + -- Filter the imports according to the import list - filterImports imp_mod is_boot imp_spec avails `thenM` \ (filtered_avails, explicits) -> + filterImports imp_mod want_boot imp_details avails `thenM` \ (filtered_avails, explicits) -> let -- Compute new transitive dependencies @@ -181,7 +186,7 @@ importsFromImportDecl this_mod -- (a) remove this_mod (might be there as a hi-boot) -- (b) add imp_mod itself -- Take its dependent packages unchanged - ((imp_mod_name, is_boot) : filter not_self (dep_mods deps), dep_pkgs deps) + ((imp_mod_name, want_boot) : filter not_self (dep_mods deps), dep_pkgs deps) | otherwise = -- Imported module is from another package @@ -192,10 +197,10 @@ importsFromImportDecl this_mod not_self (m, _) = m /= this_mod_name - import_all = case imp_spec of - Just (isHid, ls) -- Imports are spec'd explicitly - | not isHid -> Just (not (null ls)) - _ -> Nothing -- Everything is imported, + import_all = case imp_details of + Just (is_hiding, ls) -- Imports are spec'd explicitly + | not is_hiding -> Just (not (null ls)) + _ -> Nothing -- Everything is imported, -- (or almost everything [hiding]) qual_mod_name = case as_mod of @@ -206,12 +211,17 @@ importsFromImportDecl this_mod -- We need to know this so we know what to export when we see -- module M ( module P ) where ... -- Then we must export whatever came from P unqualified. + imp_spec = ImportSpec { is_mod = imp_mod_name, is_qual = qual_only, + is_loc = iloc , is_as = qual_mod_name } + mk_deprec = mi_dep_fn iface + gres = [ GRE { gre_name = name, + gre_prov = Imported [imp_spec] (name `elemNameSet` explicits), + gre_deprec = mk_deprec name } + | avail <- filtered_avails, name <- availNames avail ] + gbl_env = mkGlobalRdrEnv gres + avail_env = mkAvailEnv filtered_avails - - mk_prov name = NonLocalDef (UserImport imp_mod iloc (name `elemNameSet` explicits)) - gbl_env = mkGlobalRdrEnv qual_mod_name (not qual_only) - mk_prov filtered_avails deprecs - imports = ImportAvails { + imports = ImportAvails { imp_qual = unitModuleEnvByName qual_mod_name avail_env, imp_env = avail_env, imp_mods = unitModuleEnv imp_mod (imp_mod, import_all), @@ -228,13 +238,26 @@ importsFromImportDecl this_mod ) `thenM_` returnM (gbl_env, imports) - } -mkModDeps :: [(ModuleName, IsBootInterface)] - -> ModuleEnv (ModuleName, IsBootInterface) -mkModDeps deps = foldl add emptyModuleEnv deps - where - add env elt@(m,_) = extendModuleEnvByName env m elt +exportsToAvails :: [IfaceExport] -> TcRnIf gbl lcl Avails +exportsToAvails exports + = do { avails_by_module <- mappM do_one exports + ; return (concat avails_by_module) } + where + do_one (mod_name, exports) = mapM (do_avail mod_name) exports + do_avail mod (Avail n) = do { n' <- lookupOrig mod n; + ; return (Avail n') } + do_avail mod (AvailTC n ns) = do { n' <- lookupOrig mod n + ; ns' <- mappM (lookupImplicitOrig n') ns + ; return (AvailTC n' ns') } + -- Note the lookupImplicitOrig. It ensures that the subordinate names + -- record their parent; and that in turn ensures that the GlobalRdrEnv + -- has the correct parent for all the names in its range. + -- For imported things, we only suck in the binding site later, if ever. + +warnRedundantSourceImport mod_name + = ptext SLIT("Unnecessary {- SOURCE -} in the import of module") + <+> quotes (ppr mod_name) \end{code} @@ -253,7 +276,7 @@ Complain about duplicate bindings \begin{code} importsFromLocalDecls :: HsGroup RdrName - -> TcRn m (GlobalRdrEnv, ImportAvails) + -> RnM (GlobalRdrEnv, ImportAvails) importsFromLocalDecls group = getModule `thenM` \ this_mod -> getLocalDeclBinders this_mod group `thenM` \ avails -> @@ -273,12 +296,12 @@ importsFromLocalDecls group doptM Opt_NoImplicitPrelude `thenM` \ implicit_prelude -> let - mod_name = moduleName this_mod - mk_prov n = LocalDef -- Provenance is local - - unqual_imp = True -- Want unqualified names in scope - gbl_env = mkGlobalRdrEnv mod_name unqual_imp mk_prov avails NoDeprecs - -- NoDeprecs: don't complain about locally defined names + mod_name = moduleName this_mod + prov = LocalDef mod_name + gbl_env = mkGlobalRdrEnv gres + gres = [ GRE { gre_name = name, gre_prov = prov, gre_deprec = Nothing} + | name <- all_names] + -- gre_deprecs = Nothing: don't deprecate locally defined names -- For a start, we may be exporting a deprecated thing -- Also we may use a deprecated thing in the defn of another -- deprecated things. We may even use a deprecated thing in @@ -300,8 +323,9 @@ importsFromLocalDecls group -- defn of gbl_env above). Stupid reason: when parsing -- data type decls, the constructors start as Exact tycon-names, -- and then get turned into data con names by zapping the name space; - -- but that stops them being Exact, so they get looked up. Sigh. - -- It doesn't matter because it only affects the Data.Tuple really. + -- but that stops them being Exact, so they get looked up. + -- Ditto in fixity decls; e.g. infix 5 : + -- Sigh. It doesn't matter because it only affects the Data.Tuple really. -- The important thing is to trim down the exports. avails' | implicit_prelude = filter not_built_in_syntax avails @@ -309,7 +333,7 @@ importsFromLocalDecls group not_built_in_syntax a = not (all isBuiltInSyntaxName (availNames a)) -- Only filter it if all the names of the avail are built-in -- In particular, lists have (:) which is not built in syntax - -- so we don't filter it out. + -- so we don't filter it out. [Sept 03: wrong: see isBuiltInSyntaxName] avail_env = mkAvailEnv avails' imports = emptyImportAvails { @@ -334,7 +358,7 @@ files (@loadDecl@ calls @getTyClDeclBinders@). *** See "THE NAMING STORY" in HsDecls **** \begin{code} -getLocalDeclBinders :: Module -> HsGroup RdrName -> TcRn m [AvailInfo] +getLocalDeclBinders :: Module -> HsGroup RdrName -> RnM [AvailInfo] getLocalDeclBinders mod (HsGroup {hs_valds = val_decls, hs_tyclds = tycl_decls, hs_fords = foreign_decls }) @@ -343,18 +367,22 @@ getLocalDeclBinders mod (HsGroup {hs_valds = val_decls, -- permanently bound into the TyCons and Classes. They don't need -- an export indicator because they are all implicitly exported. - mappM new_tc tycl_decls `thenM` \ tc_avails -> - mappM new_bndr (for_hs_bndrs ++ val_hs_bndrs) `thenM` \ simple_bndrs -> - - returnM (tc_avails ++ map Avail simple_bndrs) + mappM new_tc tycl_decls `thenM` \ tc_avails -> + mappM new_simple (for_hs_bndrs ++ val_hs_bndrs) `thenM` \ simple_avails -> + returnM (tc_avails ++ simple_avails) where - new_bndr (rdr_name,loc) = newTopBinder mod rdr_name loc + new_simple rdr_name = newTopSrcBinder mod Nothing rdr_name `thenM` \ name -> + returnM (Avail name) val_hs_bndrs = collectLocatedHsBinders val_decls for_hs_bndrs = [(nm,loc) | ForeignImport nm _ _ _ loc <- foreign_decls] - new_tc tc_decl = mappM new_bndr (tyClDeclNames tc_decl) `thenM` \ names@(main_name:_) -> - returnM (AvailTC main_name names) + new_tc tc_decl + = newTopSrcBinder mod Nothing main_rdr `thenM` \ main_name -> + mappM (newTopSrcBinder mod (Just main_name)) sub_rdrs `thenM` \ sub_names -> + returnM (AvailTC main_name (main_name : sub_names)) + where + (main_rdr : sub_rdrs) = tyClDeclNames tc_decl \end{code} @@ -372,7 +400,7 @@ filterImports :: Module -- The module being imported -> IsBootInterface -- Tells whether it's a {-# SOURCE #-} import -> Maybe (Bool, [RdrNameIE]) -- Import spec; True => hiding -> [AvailInfo] -- What's available - -> TcRn m ([AvailInfo], -- What's imported + -> RnM ([AvailInfo], -- What's imported NameSet) -- What was imported explicitly -- Complains if import spec mentions things that the module doesn't export @@ -407,7 +435,7 @@ filterImports mod from (Just (want_hiding, import_items)) total_avails bale_out item = addErr (badImportItemErr mod from item) `thenM_` returnM [] - get_item :: RdrNameIE -> TcRn m [(AvailInfo, [Name])] + get_item :: RdrNameIE -> RnM [(AvailInfo, [Name])] -- Empty list for a bad item. -- Singleton is typical case. -- Can have two when we are hiding, and mention C which might be @@ -531,7 +559,7 @@ type ExportOccMap = FiniteMap OccName (Name, RdrNameIE) exportsFromAvail :: Maybe Module -- Nothing => no 'module M(..) where' header at all -> Maybe [RdrNameIE] -- Nothing => no explicit export list - -> TcRn m Avails + -> RnM Avails -- Complains if two distinct exports have same OccName -- Warns about identical exports. -- Complains about exports items not in scope @@ -551,9 +579,9 @@ exportsFromAvail maybe_mod exports = case maybe_mod of Just mod -> exports Nothing | ghci_mode == Interactive -> Nothing - | otherwise -> Just [IEVar main_RDR_Unqual] } ; + | otherwise -> Just [IEVar main_RDR_Unqual] } ; - exports_from_avail exports rdr_env imports } + exports_from_avail real_exports rdr_env imports } exports_from_avail Nothing rdr_env imports@(ImportAvails { imp_env = entity_avail_env }) @@ -563,12 +591,11 @@ exports_from_avail Nothing rdr_env -- (b) locally defined, (c) a 'main' name -- Then we look up in the entity-avail-env return [ lookupAvailEnv entity_avail_env name - | (rdr_name, gres) <- rdrEnvToList rdr_env, - isQual rdr_name, -- Avoid duplicates - GRE { gre_name = name, - gre_parent = Nothing, -- Main things only - gre_prov = LocalDef } <- gres - ] + | gre <- globalRdrEnvElts rdr_env, + isLocalGRE gre, + let name = gre_name gre, + isNothing (nameParent_maybe name) -- Main things only + ] exports_from_avail (Just export_items) rdr_env (ImportAvails { imp_qual = mod_avail_env, @@ -578,7 +605,7 @@ exports_from_avail (Just export_items) rdr_env returnM (nameEnvElts export_avail_map) where - exports_from_item :: ExportAccum -> RdrNameIE -> TcRn m ExportAccum + exports_from_item :: ExportAccum -> RdrNameIE -> RnM ExportAccum exports_from_item acc@(mods, occs, avails) ie@(IEModuleContents mod) | mod `elem` mods -- Duplicate export of M @@ -610,15 +637,13 @@ exports_from_avail (Just export_items) rdr_env returnM (mod:mods, occs', avails') exports_from_item acc@(mods, occs, avails) ie - = lookupGRE (ieName ie) `thenM` \ mb_gre -> - case mb_gre of { - Nothing -> addErr (unknownNameErr (ieName ie)) `thenM_` - returnM acc ; - Just gre -> - + = lookupGlobalOccRn (ieName ie) `thenM` \ name -> + if isUnboundName name then + returnM acc -- Avoid error cascade + else -- Get the AvailInfo for the parent of the specified name let - parent = gre_parent gre `orElse` gre_name gre + parent = nameParent name avail = lookupAvailEnv entity_avail_env parent in -- Filter out the bits we want @@ -633,7 +658,7 @@ exports_from_avail (Just export_items) rdr_env warnIf (not (ok_item ie avail)) (dodgyExportWarn ie) `thenM_` check_occs ie occs export_avail `thenM` \ occs' -> returnM (mods, occs', addAvail avails export_avail) - }} + } ------------------------------- @@ -651,10 +676,7 @@ filter_unqual env (AvailTC n ns) in_scope :: GlobalRdrEnv -> Name -> Bool -- Checks whether the Name is in scope unqualified, -- regardless of whether it's ambiguous or not -in_scope env n - = case lookupRdrEnv env (mkRdrUnqual (nameOccName n)) of - Nothing -> False - Just gres -> or [n == gre_name g | g <- gres] +in_scope env n = any unQualOK (lookupGRE_Name env n) ------------------------------- @@ -665,7 +687,7 @@ ok_item (IEThingAll _) (AvailTC _ [n]) = False ok_item _ _ = True ------------------------------- -check_occs :: RdrNameIE -> ExportOccMap -> AvailInfo -> TcRn m ExportOccMap +check_occs :: RdrNameIE -> ExportOccMap -> AvailInfo -> RnM ExportOccMap check_occs ie occs avail = foldlM check occs (availNames avail) where @@ -694,35 +716,28 @@ check_occs ie occs avail %********************************************************* \begin{code} -reportUnusedNames :: TcGblEnv -> DefUses -> TcRn m () -reportUnusedNames gbl_env dus +reportUnusedNames :: TcGblEnv -> RnM () +reportUnusedNames gbl_env = warnUnusedModules unused_imp_mods `thenM_` warnUnusedTopBinds bad_locals `thenM_` warnUnusedImports bad_imports `thenM_` printMinimalImports minimal_imports where - used_names :: NameSet - used_names = findUses dus emptyNameSet + used_names, all_used_names :: NameSet + used_names = findUses (tcg_dus gbl_env) emptyNameSet + all_used_names = used_names `unionNameSets` + mkNameSet (mapCatMaybes nameParent_maybe (nameSetToList used_names)) + -- A use of C implies a use of T, + -- if C was brought into scope by T(..) or T(C) -- Collect the defined names from the in-scope environment - -- Look for the qualified ones only, else get duplicates defined_names :: [GlobalRdrElt] - defined_names = foldRdrEnv add [] (tcg_rdr_env gbl_env) - add rdr_name ns acc | isQual rdr_name = ns ++ acc - | otherwise = acc + defined_names = globalRdrEnvElts (tcg_rdr_env gbl_env) defined_and_used, defined_but_not_used :: [GlobalRdrElt] (defined_and_used, defined_but_not_used) = partition is_used defined_names - is_used gre = n `elemNameSet` used_names || any (`elemNameSet` used_names) kids - -- The 'kids' part is because a use of C implies a use of T, - -- if C was brought into scope by T(..) or T(C) - where - n = gre_name gre - kids = case lookupAvailEnv_maybe avail_env n of - Just (AvailTC n ns) -> ns - other -> [] -- Ids, class ops and datacons - -- (The latter two give Nothing) + is_used gre = gre_name gre `elemNameSet` all_used_names -- Filter out the ones that are -- (a) defined in this module, and @@ -735,8 +750,11 @@ reportUnusedNames gbl_env dus bad_imports :: [GlobalRdrElt] bad_imports = filter bad_imp defined_but_not_used - bad_imp (GRE {gre_prov = NonLocalDef (UserImport mod _ True)}) = not (module_unused mod) - bad_imp other = False + bad_imp (GRE {gre_prov = Imported imp_specs True}) + = not (all (module_unused . is_mod) imp_specs) + -- Don't complain about unused imports if we've already said the + -- entire import is unused + bad_imp other = False -- To figure out the minimal set of imports, start with the things -- that are in scope (i.e. in gbl_env). Then just combine them @@ -764,10 +782,10 @@ reportUnusedNames gbl_env dus -- We've carefully preserved the provenance so that we can -- construct minimal imports that import the name by (one of) -- the same route(s) as the programmer originally did. - add_name (GRE {gre_name = n, gre_parent = p, - gre_prov = NonLocalDef (UserImport m _ _)}) acc - = addToFM_C plusAvailEnv acc (moduleName m) - (unitAvailEnv (mk_avail n p)) + add_name (GRE {gre_name = n, + gre_prov = Imported imp_specs _}) acc + = addToFM_C plusAvailEnv acc (is_mod (head imp_specs)) + (unitAvailEnv (mk_avail n (nameParent_maybe n))) add_name other acc = acc @@ -782,8 +800,7 @@ reportUnusedNames gbl_env dus -- Add an empty collection of imports for a module -- from which we have sucked only instance decls - imports = tcg_imports gbl_env - avail_env = imp_env imports + imports = tcg_imports gbl_env direct_import_mods :: [ModuleName] direct_import_mods = map (moduleName . fst) @@ -803,14 +820,17 @@ reportUnusedNames gbl_env dus isNothing (lookupFM minimal_imports1 m), m /= pRELUDE_Name, not (hasEmptyImpList m)] - - module_unused :: Module -> Bool - module_unused mod = moduleName mod `elem` unused_imp_mods + -- hasEmptyImpList arranges not to complain about + -- import M (), which is an idiom for importing + -- instance declarations + + module_unused :: ModuleName -> Bool + module_unused mod = mod `elem` unused_imp_mods -- ToDo: deal with original imports with 'qualified' and 'as M' clauses printMinimalImports :: FiniteMap ModuleName AvailEnv -- Minimal imports - -> TcRn m () + -> RnM () printMinimalImports imps = ifOptM Opt_D_dump_minimal_imports $ do { @@ -835,7 +855,7 @@ printMinimalImports imps to_ies (mod, avail_env) = mappM to_ie (availEnvElts avail_env) `thenM` \ ies -> returnM (mod, ies) - to_ie :: AvailInfo -> TcRn m (IE Name) + to_ie :: AvailInfo -> RnM (IE Name) -- The main trick here is that if we're importing all the constructors -- we want to say "T(..)", but if we're importing only a subset we want -- to say "T(A,B,C)". So we have to find out what the module exports. @@ -843,18 +863,19 @@ printMinimalImports imps to_ie (AvailTC n [m]) = ASSERT( n==m ) returnM (IEThingAbs n) to_ie (AvailTC n ns) - = loadInterface (text "Compute minimal imports from" <+> ppr n_mod) - n_mod ImportBySystem `thenM` \ iface -> + = loadSrcInterface doc n_mod False `thenM` \ iface -> case [xs | (m,as) <- mi_exports iface, m == n_mod, AvailTC x xs <- as, - x == n] of - [xs] | all (`elem` ns) xs -> returnM (IEThingAll n) - | otherwise -> returnM (IEThingWith n (filter (/= n) ns)) - other -> pprTrace "to_ie" (ppr n <+> ppr (nameModule n) <+> ppr other) $ - returnM (IEVar n) + x == nameOccName n] of + [xs] | all_used xs -> returnM (IEThingAll n) + | otherwise -> returnM (IEThingWith n (filter (/= n) ns)) + other -> pprTrace "to_ie" (ppr n <+> ppr n_mod <+> ppr other) $ + returnM (IEVar n) where - n_mod = moduleName (nameModule n) + all_used avail_occs = all (`elem` map nameOccName ns) avail_occs + doc = text "Compute minimal imports from" <+> ppr n + n_mod = nameModuleName n \end{code} @@ -897,15 +918,9 @@ exportClashErr global_env name1 name2 ie1 ie2 ppr_export ie name = nest 2 (quotes (ppr ie) <+> ptext SLIT("exports") <+> quotes (ppr name) <+> pprNameProvenance (get_gre name)) - -- get_gre finds a GRE for the Name, in a very inefficient way - -- There isn't a more efficient way to do it, because we don't necessarily - -- know the RdrName under which this Name is in scope. So we just - -- search linearly. Shouldn't matter because this only happens - -- in an error message. + -- get_gre finds a GRE for the Name, so that we can show its provenance get_gre name - = case [gre | gres <- rdrEnvElts global_env, - gre <- gres, - gre_name gre == name] of + = case lookupGRE_Name global_env name of (gre:_) -> gre [] -> pprPanic "exportClashErr" (ppr name) diff --git a/ghc/compiler/rename/RnSource.lhs b/ghc/compiler/rename/RnSource.lhs index ee01065696..8a7e7b2ff6 100644 --- a/ghc/compiler/rename/RnSource.lhs +++ b/ghc/compiler/rename/RnSource.lhs @@ -5,63 +5,46 @@ \begin{code} module RnSource ( - rnSrcDecls, checkModDeprec, - rnTyClDecl, rnIfaceRuleDecl, rnInstDecl, - rnBinds, rnBindsAndThen, rnStats, + rnSrcDecls, addTcgDUs, + rnTyClDecls, checkModDeprec, + rnBinds, rnBindsAndThen ) where #include "HsVersions.h" import HsSyn -import RdrName ( RdrName, isRdrDataCon, elemRdrEnv ) -import RdrHsSyn ( RdrNameConDecl, RdrNameTyClDecl, +import RdrName ( RdrName, isRdrDataCon, rdrNameOcc, elemLocalRdrEnv ) +import RdrHsSyn ( RdrNameConDecl, RdrNameHsBinds, RdrNameDeprecation, RdrNameFixitySig, - RdrNameHsBinds, - extractGenericPatTyVars - ) + extractGenericPatTyVars ) import RnHsSyn -import HsCore import RnExpr ( rnExpr ) import RnTypes ( rnHsType, rnHsSigType, rnHsTypeFVs, rnContext ) - import RnBinds ( rnTopMonoBinds, rnMonoBinds, rnMethodBinds, rnMonoBindsAndThen, renameSigs, checkSigs ) -import RnEnv ( lookupTopBndrRn, lookupOccRn, lookupSysBndr, - newLocalsRn, lookupGlobalOccRn, +import RnEnv ( lookupTopBndrRn, lookupTopFixSigNames, + lookupOccRn, newLocalsRn, bindLocalsFV, bindPatSigTyVarsFV, bindTyVarsRn, extendTyVarEnvFVRn, - bindCoreLocalRn, bindCoreLocalsRn, bindLocalNames, - checkDupOrQualNames, checkDupNames, mapFvRn, - lookupTopSrcBndr_maybe, lookupTopSrcBndr, - dataTcOccs, newIPName, unknownNameErr + bindLocalNames, newIPNameRn, + checkDupNames, mapFvRn, + unknownNameErr ) import TcRnMonad -import BasicTypes ( FixitySig(..), TopLevelFlag(..) ) -import HscTypes ( ExternalPackageState(..), FixityEnv, - Deprecations(..), plusDeprecs ) -import Module ( moduleEnvElts ) -import Class ( FunDep, DefMeth (..) ) -import TyCon ( DataConDetails(..), visibleDataCons ) +import BasicTypes ( TopLevelFlag(..) ) +import HscTypes ( FixityEnv, FixItem(..), + Deprecations, Deprecs(..), DeprecTxt, plusDeprecs ) +import Class ( FunDep ) import Name ( Name ) import NameSet import NameEnv -import ErrUtils ( dumpIfSet ) -import PrelNames ( newStablePtrName, bindIOName, returnIOName - -- dotnet interop - , objectTyConName, - , unmarshalObjectName, marshalObjectName - , unmarshalStringName, marshalStringName - , checkDotnetResName - ) -import List ( partition ) -import Bag ( bagToList ) import Outputable import SrcLoc ( SrcLoc ) import CmdLineOpts ( DynFlag(..) ) -- Warn of unused for-all'd tyvars -import Maybes ( maybeToBool, seqMaybe ) -import Maybe ( maybe, catMaybes, isNothing ) +import Maybes ( seqMaybe ) +import Maybe ( catMaybes, isNothing ) \end{code} @rnSourceDecl@ `renames' declarations. @@ -81,7 +64,7 @@ Checks the @(..)@ etc constraints in the export list. \begin{code} -rnSrcDecls :: HsGroup RdrName -> RnM (TcGblEnv, HsGroup Name, DefUses) +rnSrcDecls :: HsGroup RdrName -> RnM (TcGblEnv, HsGroup Name) rnSrcDecls (HsGroup { hs_valds = MonoBind binds sigs _, hs_tyclds = tycl_decls, @@ -90,8 +73,7 @@ rnSrcDecls (HsGroup { hs_valds = MonoBind binds sigs _, hs_depds = deprec_decls, hs_fords = foreign_decls, hs_defds = default_decls, - hs_ruleds = rule_decls, - hs_coreds = core_decls }) + hs_ruleds = rule_decls }) = do { -- Deal with deprecations (returns only the extra deprecations) deprecs <- rnSrcDeprecDecls deprec_decls ; @@ -114,12 +96,11 @@ rnSrcDecls (HsGroup { hs_valds = MonoBind binds sigs _, -- So we content ourselves with gathering uses only; that -- means we'll only report a declaration as unused if it isn't -- mentioned at all. Ah well. - (rn_tycl_decls, src_fvs1) <- mapFvRn rnSrcTyClDecl tycl_decls ; + (rn_tycl_decls, src_fvs1) <- mapFvRn rnTyClDecl tycl_decls ; (rn_inst_decls, src_fvs2) <- mapFvRn rnSrcInstDecl inst_decls ; (rn_rule_decls, src_fvs3) <- mapFvRn rnHsRuleDecl rule_decls ; (rn_foreign_decls, src_fvs4) <- mapFvRn rnHsForeignDecl foreign_decls ; (rn_default_decls, src_fvs5) <- mapFvRn rnDefaultDecl default_decls ; - (rn_core_decls, src_fvs6) <- mapFvRn rnCoreDecl core_decls ; let { rn_group = HsGroup { hs_valds = rn_val_decls, @@ -129,17 +110,22 @@ rnSrcDecls (HsGroup { hs_valds = MonoBind binds sigs _, hs_depds = [], hs_fords = rn_foreign_decls, hs_defds = rn_default_decls, - hs_ruleds = rn_rule_decls, - hs_coreds = rn_core_decls } ; + hs_ruleds = rn_rule_decls } ; other_fvs = plusFVs [src_fvs1, src_fvs2, src_fvs3, - src_fvs4, src_fvs5, src_fvs6] ; + src_fvs4, src_fvs5] ; src_dus = bind_dus `plusDU` usesOnly other_fvs } ; tcg_env <- getGblEnv ; - return (tcg_env, rn_group, src_dus) + return (tcg_env `addTcgDUs` src_dus, rn_group) }}} +rnTyClDecls :: [TyClDecl RdrName] -> RnM [TyClDecl Name] +rnTyClDecls tycl_decls = do { (decls', fvs) <- mapFvRn rnTyClDecl tycl_decls + ; return decls' } + +addTcgDUs :: TcGblEnv -> DefUses -> TcGblEnv +addTcgDUs tcg_env dus = tcg_env { tcg_dus = tcg_dus tcg_env `plusDU` dus } \end{code} @@ -150,32 +136,40 @@ rnSrcDecls (HsGroup { hs_valds = MonoBind binds sigs _, %********************************************************* \begin{code} -rnSrcFixityDecls :: [RdrNameFixitySig] -> TcRn m FixityEnv +rnSrcFixityDecls :: [RdrNameFixitySig] -> RnM FixityEnv rnSrcFixityDecls fix_decls = getGblEnv `thenM` \ gbl_env -> foldlM rnFixityDecl (tcg_fix_env gbl_env) - fix_decls `thenM` \ fix_env -> - traceRn (text "fixity env" <+> ppr fix_env) `thenM_` + fix_decls `thenM` \ fix_env -> + traceRn (text "fixity env" <+> pprFixEnv fix_env) `thenM_` returnM fix_env -rnFixityDecl :: FixityEnv -> RdrNameFixitySig -> TcRn m FixityEnv +rnFixityDecl :: FixityEnv -> RdrNameFixitySig -> RnM FixityEnv rnFixityDecl fix_env (FixitySig rdr_name fixity loc) = -- GHC extension: look up both the tycon and data con -- for con-like things -- If neither are in scope, report an error; otherwise -- add both to the fixity env - mappM lookupTopSrcBndr_maybe (dataTcOccs rdr_name) `thenM` \ maybe_ns -> - case catMaybes maybe_ns of - [] -> addSrcLoc loc $ - addErr (unknownNameErr rdr_name) `thenM_` - returnM fix_env - ns -> foldlM add fix_env ns + lookupTopFixSigNames rdr_name `thenM` \ names -> + if null names then + addSrcLoc loc (addErr (unknownNameErr rdr_name)) `thenM_` + returnM fix_env + else + foldlM add fix_env names where - add fix_env name + add fix_env name = case lookupNameEnv fix_env name of - Just (FixitySig _ _ loc') -> addErr (dupFixityDecl rdr_name loc loc') `thenM_` - returnM fix_env - Nothing -> returnM (extendNameEnv fix_env name (FixitySig name fixity loc)) + Just (FixItem _ _ loc') + -> addErr (dupFixityDecl rdr_name loc loc') `thenM_` + returnM fix_env + Nothing -> returnM (extendNameEnv fix_env name fix_item) + where + fix_item = FixItem (rdrNameOcc rdr_name) fixity loc + +pprFixEnv :: FixityEnv -> SDoc +pprFixEnv env + = pprWithCommas (\ (FixItem n f _) -> ppr f <+> ppr n) + (nameEnvElts env) dupFixityDecl rdr_name loc1 loc2 = vcat [ptext SLIT("Multiple fixity declarations for") <+> quotes (ppr rdr_name), @@ -195,7 +189,7 @@ It's only imported deprecations, dealt with in RnIfaces, that we gather them together. \begin{code} -rnSrcDeprecDecls :: [RdrNameDeprecation] -> TcRn m Deprecations +rnSrcDeprecDecls :: [RdrNameDeprecation] -> RnM Deprecations rnSrcDeprecDecls [] = returnM NoDeprecs @@ -204,18 +198,14 @@ rnSrcDeprecDecls decls returnM (DeprecSome (mkNameEnv (catMaybes pairs))) where rn_deprec (Deprecation rdr_name txt loc) - = addSrcLoc loc $ - lookupTopSrcBndr rdr_name `thenM` \ name -> - returnM (Just (name, (name,txt))) + = addSrcLoc loc $ + lookupTopBndrRn rdr_name `thenM` \ name -> + returnM (Just (name, (rdrNameOcc rdr_name, txt))) checkModDeprec :: Maybe DeprecTxt -> Deprecations -- Check for a module deprecation; done once at top level checkModDeprec Nothing = NoDeprecs -checkModdeprec (Just txt) = DeprecAll txt - -badDeprec d - = sep [ptext SLIT("Illegal deprecation when whole module is deprecated"), - nest 4 (ppr d)] +checkModDeprec (Just txt) = DeprecAll txt \end{code} %********************************************************* @@ -225,33 +215,12 @@ badDeprec d %********************************************************* \begin{code} -rnSrcTyClDecl tycl_decl - = rnTyClDecl tycl_decl `thenM` \ new_decl -> - finishSourceTyClDecl tycl_decl new_decl `thenM` \ (new_decl', fvs) -> - returnM (new_decl', fvs `plusFV` tyClDeclFVs new_decl') - -rnSrcInstDecl inst - = rnInstDecl inst `thenM` \ new_inst -> - finishSourceInstDecl inst new_inst `thenM` \ (new_inst', fvs) -> - returnM (new_inst', fvs `plusFV` instDeclFVs new_inst') - rnDefaultDecl (DefaultDecl tys src_loc) - = addSrcLoc src_loc $ - mapFvRn (rnHsTypeFVs doc_str) tys `thenM` \ (tys', fvs) -> + = addSrcLoc src_loc $ + mapFvRn (rnHsTypeFVs doc_str) tys `thenM` \ (tys', fvs) -> returnM (DefaultDecl tys' src_loc, fvs) where doc_str = text "In a `default' declaration" - - -rnCoreDecl (CoreDecl name ty rhs loc) - = addSrcLoc loc $ - lookupTopBndrRn name `thenM` \ name' -> - rnHsTypeFVs doc_str ty `thenM` \ (ty', ty_fvs) -> - rnCoreExpr rhs `thenM` \ rhs' -> - returnM (CoreDecl name' ty' rhs' loc, - ty_fvs `plusFV` ufExprFVs rhs') - where - doc_str = text "In the Core declaration for" <+> quotes (ppr name) \end{code} %********************************************************* @@ -285,22 +254,17 @@ rnBindsAndThen (IPBinds binds) thing_inside = rnIPBinds binds `thenM` \ (binds',fv_binds) -> thing_inside (IPBinds binds') `thenM` \ (thing, fvs_thing) -> returnM (thing, fvs_thing `plusFV` fv_binds) -\end{code} - -%************************************************************************ -%* * -\subsubsection{@rnIPBinds@s: in implicit parameter bindings} * -%* * -%************************************************************************ - -\begin{code} rnIPBinds [] = returnM ([], emptyFVs) rnIPBinds ((n, expr) : binds) - = newIPName n `thenM` \ name -> + = newIPNameRn n `thenM` \ name -> rnExpr expr `thenM` \ (expr',fvExpr) -> rnIPBinds binds `thenM` \ (binds',fvBinds) -> returnM ((name, expr') : binds', fvExpr `plusFV` fvBinds) + +badIpBinds binds + = hang (ptext SLIT("Implicit-parameter bindings illegal in 'mdo':")) 4 + (ppr binds) \end{code} @@ -315,31 +279,13 @@ rnHsForeignDecl (ForeignImport name ty spec isDeprec src_loc) = addSrcLoc src_loc $ lookupTopBndrRn name `thenM` \ name' -> rnHsTypeFVs (fo_decl_msg name) ty `thenM` \ (ty', fvs) -> - returnM (ForeignImport name' ty' spec isDeprec src_loc, - fvs `plusFV` extras spec) - where - extras (CImport _ _ _ _ CWrapper) - = mkFVs [ newStablePtrName - , bindIOName - , returnIOName - ] - extras (DNImport _) - = mkFVs [ bindIOName - , objectTyConName - , unmarshalObjectName - , marshalObjectName - , marshalStringName - , unmarshalStringName - , checkDotnetResName - ] - extras _ = emptyFVs + returnM (ForeignImport name' ty' spec isDeprec src_loc, fvs) rnHsForeignDecl (ForeignExport name ty spec isDeprec src_loc) = addSrcLoc src_loc $ - lookupOccRn name `thenM` \ name' -> - rnHsTypeFVs (fo_decl_msg name) ty `thenM` \ (ty', fvs) -> - returnM (ForeignExport name' ty' spec isDeprec src_loc, - mkFVs [name', bindIOName, returnIOName] `plusFV` fvs ) + lookupOccRn name `thenM` \ name' -> + rnHsTypeFVs (fo_decl_msg name) ty `thenM` \ (ty', fvs) -> + returnM (ForeignExport name' ty' spec isDeprec src_loc, fvs ) -- NB: a foreign export is an *occurrence site* for name, so -- we add it to the free-variable list. It might, for example, -- be imported from another module @@ -355,42 +301,25 @@ fo_decl_msg name = ptext SLIT("In the foreign declaration for") <+> ppr name %********************************************************* \begin{code} -rnInstDecl (InstDecl inst_ty mbinds uprags maybe_dfun_rdr_name src_loc) +rnSrcInstDecl (InstDecl inst_ty mbinds uprags src_loc) -- Used for both source and interface file decls = addSrcLoc src_loc $ rnHsSigType (text "an instance decl") inst_ty `thenM` \ inst_ty' -> - (case maybe_dfun_rdr_name of - Nothing -> returnM Nothing - Just dfun_rdr_name -> lookupGlobalOccRn dfun_rdr_name `thenM` \ dfun_name -> - returnM (Just dfun_name) - ) `thenM` \ maybe_dfun_name -> - - -- The typechecker checks that all the bindings are for the right class. - returnM (InstDecl inst_ty' EmptyMonoBinds [] maybe_dfun_name src_loc) - --- Compare finishSourceTyClDecl -finishSourceInstDecl (InstDecl _ mbinds uprags _ _ ) - (InstDecl inst_ty _ _ maybe_dfun_name src_loc) - -- Used for both source decls only - = ASSERT( not (maybeToBool maybe_dfun_name) ) -- Source decl! + -- Rename the bindings + -- The typechecker (not the renamer) checks that all + -- the bindings are for the right class let meth_doc = text "In the bindings in an instance declaration" meth_names = collectLocatedMonoBinders mbinds - (inst_tyvars, _, cls,_) = splitHsInstDeclTy inst_ty - -- (Slightly strangely) the forall-d tyvars scope over - -- the method bindings too + (inst_tyvars, _, cls,_) = splitHsInstDeclTy inst_ty' in - - -- Rename the bindings - -- NB meth_names can be qualified! - checkDupNames meth_doc meth_names `thenM_` + checkDupNames meth_doc meth_names `thenM_` extendTyVarEnvForMethodBinds inst_tyvars ( + -- (Slightly strangely) the forall-d tyvars scope over + -- the method bindings too rnMethodBinds cls [] mbinds ) `thenM` \ (mbinds', meth_fvs) -> - let - binders = collectMonoBinders mbinds' - in -- Rename the prags and signatures. -- Note that the type variables are not in scope here, -- so that instance Eq a => Eq (T a) where @@ -398,13 +327,30 @@ finishSourceInstDecl (InstDecl _ mbinds uprags _ _ ) -- works OK. -- -- But the (unqualified) method names are in scope + let + binders = collectMonoBinders mbinds' + in bindLocalNames binders (renameSigs uprags) `thenM` \ uprags' -> checkSigs (okInstDclSig (mkNameSet binders)) uprags' `thenM_` - returnM (InstDecl inst_ty mbinds' uprags' maybe_dfun_name src_loc, - meth_fvs `plusFV` hsSigsFVs uprags') + returnM (InstDecl inst_ty' mbinds' uprags' src_loc, + meth_fvs `plusFV` hsSigsFVs uprags' + `plusFV` extractHsTyNames inst_ty') \end{code} +For the method bindings in class and instance decls, we extend the +type variable environment iff -fglasgow-exts + +\begin{code} +extendTyVarEnvForMethodBinds tyvars thing_inside + = doptM Opt_GlasgowExts `thenM` \ opt_GlasgowExts -> + if opt_GlasgowExts then + extendTyVarEnvFVRn (map hsTyVarName tyvars) thing_inside + else + thing_inside +\end{code} + + %********************************************************* %* * \subsection{Rules} @@ -412,18 +358,6 @@ finishSourceInstDecl (InstDecl _ mbinds uprags _ _ ) %********************************************************* \begin{code} -rnIfaceRuleDecl (IfaceRule rule_name act vars fn args rhs src_loc) - = addSrcLoc src_loc $ - lookupOccRn fn `thenM` \ fn' -> - rnCoreBndrs vars $ \ vars' -> - mappM rnCoreExpr args `thenM` \ args' -> - rnCoreExpr rhs `thenM` \ rhs' -> - returnM (IfaceRule rule_name act vars' fn' args' rhs' src_loc) - -rnIfaceRuleDecl (IfaceRuleOut fn rule) -- Builtin rules come this way - = lookupOccRn fn `thenM` \ fn' -> - returnM (IfaceRuleOut fn' rule) - rnHsRuleDecl (HsRule rule_name act vars lhs rhs src_loc) = addSrcLoc src_loc $ bindPatSigTyVarsFV (collectRuleBndrSigTys vars) $ @@ -443,7 +377,7 @@ rnHsRuleDecl (HsRule rule_name act vars lhs rhs src_loc) in mappM (addErr . badRuleVar rule_name) bad_vars `thenM_` returnM (HsRule rule_name act vars' lhs' rhs' src_loc, - fv_vars `plusFV` fv_lhs `plusFV` fv_rhs) + fv_vars `plusFV` fv_lhs `plusFV` fv_rhs) where doc = text "In the transformation rule" <+> ftext rule_name @@ -488,6 +422,18 @@ validRuleLhs foralls lhs check_e other = Just other -- Fails check_es es = foldr (seqMaybe . check_e) Nothing es + +badRuleLhsErr name lhs (Just bad_e) + = sep [ptext SLIT("Rule") <+> ftext name <> colon, + nest 4 (vcat [ptext SLIT("Illegal expression:") <+> ppr bad_e, + ptext SLIT("in left-hand side:") <+> ppr lhs])] + $$ + ptext SLIT("LHS must be of form (f e1 .. en) where f is not forall'd") + +badRuleVar name var + = sep [ptext SLIT("Rule") <+> doubleQuotes (ftext name) <> colon, + ptext SLIT("Forall'd variable") <+> quotes (ppr var) <+> + ptext SLIT("does not appear on left hand side")] \end{code} @@ -511,120 +457,75 @@ and then go over it again to rename the tyvars! However, we can also do some scoping checks at the same time. \begin{code} -rnTyClDecl (IfaceSig {tcdName = name, tcdType = ty, tcdIdInfo = id_infos, tcdLoc = loc}) - = addSrcLoc loc $ - lookupTopBndrRn name `thenM` \ name' -> - rnHsType doc_str ty `thenM` \ ty' -> - mappM rnIdInfo id_infos `thenM` \ id_infos' -> - returnM (IfaceSig {tcdName = name', tcdType = ty', tcdIdInfo = id_infos', tcdLoc = loc}) - where - doc_str = text "In the interface signature for" <+> quotes (ppr name) - rnTyClDecl (ForeignType {tcdName = name, tcdFoType = fo_type, tcdExtName = ext_name, tcdLoc = loc}) = addSrcLoc loc $ lookupTopBndrRn name `thenM` \ name' -> - returnM (ForeignType {tcdName = name', tcdFoType = fo_type, tcdExtName = ext_name, tcdLoc = loc}) + returnM (ForeignType {tcdName = name', tcdFoType = fo_type, tcdExtName = ext_name, tcdLoc = loc}, + emptyFVs) rnTyClDecl (TyData {tcdND = new_or_data, tcdCtxt = context, tcdName = tycon, - tcdTyVars = tyvars, tcdCons = condecls, tcdGeneric = want_generic, - tcdDerivs = derivs, tcdLoc = src_loc}) + tcdTyVars = tyvars, tcdCons = condecls, + tcdDerivs = derivs, tcdLoc = src_loc}) = addSrcLoc src_loc $ lookupTopBndrRn tycon `thenM` \ tycon' -> bindTyVarsRn data_doc tyvars $ \ tyvars' -> rnContext data_doc context `thenM` \ context' -> - rn_derivs derivs `thenM` \ derivs' -> - checkDupOrQualNames data_doc con_names `thenM_` - + rn_derivs derivs `thenM` \ (derivs', deriv_fvs) -> + checkDupNames data_doc con_names `thenM_` rnConDecls tycon' condecls `thenM` \ condecls' -> returnM (TyData {tcdND = new_or_data, tcdCtxt = context', tcdName = tycon', - tcdTyVars = tyvars', tcdCons = condecls', tcdGeneric = want_generic, - tcdDerivs = derivs', tcdLoc = src_loc}) + tcdTyVars = tyvars', tcdCons = condecls', + tcdDerivs = derivs', tcdLoc = src_loc}, + delFVs (map hsTyVarName tyvars') $ + extractHsCtxtTyNames context' `plusFV` + plusFVs (map conDeclFVs condecls') `plusFV` + deriv_fvs) where data_doc = text "In the data type declaration for" <+> quotes (ppr tycon) - con_names = map conDeclName (visibleDataCons condecls) + con_names = map conDeclName condecls - rn_derivs Nothing = returnM Nothing - rn_derivs (Just ds) = rnContext data_doc ds `thenM` \ ds' -> returnM (Just ds') + rn_derivs Nothing = returnM (Nothing, emptyFVs) + rn_derivs (Just ds) = rnContext data_doc ds `thenM` \ ds' -> + returnM (Just ds', extractHsCtxtTyNames ds') rnTyClDecl (TySynonym {tcdName = name, tcdTyVars = tyvars, tcdSynRhs = ty, tcdLoc = src_loc}) = addSrcLoc src_loc $ lookupTopBndrRn name `thenM` \ name' -> bindTyVarsRn syn_doc tyvars $ \ tyvars' -> - rnHsType syn_doc ty `thenM` \ ty' -> - returnM (TySynonym {tcdName = name', tcdTyVars = tyvars', tcdSynRhs = ty', tcdLoc = src_loc}) + rnHsTypeFVs syn_doc ty `thenM` \ (ty', fvs) -> + returnM (TySynonym {tcdName = name', tcdTyVars = tyvars', + tcdSynRhs = ty', tcdLoc = src_loc}, + delFVs (map hsTyVarName tyvars') fvs) where syn_doc = text "In the declaration for type synonym" <+> quotes (ppr name) rnTyClDecl (ClassDecl {tcdCtxt = context, tcdName = cname, tcdTyVars = tyvars, tcdFDs = fds, tcdSigs = sigs, - tcdLoc = src_loc}) - -- Used for both source and interface file decls + tcdMeths = mbinds, tcdLoc = src_loc}) = addSrcLoc src_loc $ - lookupTopBndrRn cname `thenM` \ cname' -> -- Tyvars scope over superclass context and method signatures - bindTyVarsRn cls_doc tyvars $ \ tyvars' -> - - -- Check the superclasses - rnContext cls_doc context `thenM` \ context' -> - - -- Check the functional dependencies - rnFds cls_doc fds `thenM` \ fds' -> + bindTyVarsRn cls_doc tyvars ( \ tyvars' -> + rnContext cls_doc context `thenM` \ context' -> + rnFds cls_doc fds `thenM` \ fds' -> + renameSigs sigs `thenM` \ sigs' -> + returnM (tyvars', context', fds', sigs') + ) `thenM` \ (tyvars', context', fds', sigs') -> -- Check the signatures -- First process the class op sigs (op_sigs), then the fixity sigs (non_op_sigs). let - (op_sigs, non_op_sigs) = partition isClassOpSig sigs - sig_rdr_names_w_locs = [(op,locn) | ClassOpSig op _ _ locn <- sigs] + sig_rdr_names_w_locs = [(op,locn) | Sig op _ locn <- sigs] in - checkDupOrQualNames sig_doc sig_rdr_names_w_locs `thenM_` - mappM (rnClassOp cname' fds') op_sigs `thenM` \ sigs' -> - renameSigs non_op_sigs `thenM` \ non_ops' -> - checkSigs okClsDclSig non_ops' `thenM_` + checkDupNames sig_doc sig_rdr_names_w_locs `thenM_` + checkSigs okClsDclSig sigs' `thenM_` -- Typechecker is responsible for checking that we only -- give default-method bindings for things in this class. -- The renamer *could* check this for class decls, but can't -- for instance decls. - returnM (ClassDecl { tcdCtxt = context', tcdName = cname', tcdTyVars = tyvars', - tcdFDs = fds', tcdSigs = non_ops' ++ sigs', tcdMeths = Nothing, - tcdLoc = src_loc}) - where - cls_doc = text "In the declaration for class" <+> ppr cname - sig_doc = text "In the signatures for class" <+> ppr cname - -rnClassOp clas clas_fds sig@(ClassOpSig op dm_stuff ty locn) - = addSrcLoc locn $ - lookupTopBndrRn op `thenM` \ op_name -> - - -- Check the signature - rnHsSigType (quotes (ppr op)) ty `thenM` \ new_ty -> - - -- Make the default-method name - (case dm_stuff of - DefMeth dm_rdr_name - -> -- Imported class that has a default method decl - lookupSysBndr dm_rdr_name `thenM` \ dm_name -> - returnM (DefMeth dm_name) - -- An imported class decl for a class decl that had an explicit default - -- method, mentions, rather than defines, - -- the default method, so we must arrange to pull it in - - GenDefMeth -> returnM GenDefMeth - NoDefMeth -> returnM NoDefMeth - ) `thenM` \ dm_stuff' -> - - returnM (ClassOpSig op_name dm_stuff' new_ty locn) - -finishSourceTyClDecl :: RdrNameTyClDecl -> RenamedTyClDecl -> RnM (RenamedTyClDecl, FreeVars) - -- Used for source file decls only - -- Renames the default-bindings of a class decl -finishSourceTyClDecl (ClassDecl {tcdMeths = Just mbinds, tcdLoc = src_loc}) -- Get mbinds from here - rn_cls_decl@(ClassDecl {tcdName = cls, tcdTyVars = tyvars}) -- Everything else is here - -- There are some default-method bindings (abeit possibly empty) so - -- this is a source-code class declaration - = -- The newLocals call is tiresome: given a generic class decl + -- The newLocals call is tiresome: given a generic class decl -- class C a where -- op :: a -> a -- op {| x+y |} (Inl a) = ... @@ -632,48 +533,32 @@ finishSourceTyClDecl (ClassDecl {tcdMeths = Just mbinds, tcdLoc = src_loc}) -- G -- op {| a*b |} (a*b) = ... -- we want to name both "x" tyvars with the same unique, so that they are -- easy to group together in the typechecker. - -- Hence the - addSrcLoc src_loc $ - extendTyVarEnvForMethodBinds tyvars $ - getLocalRdrEnv `thenM` \ name_env -> - let - meth_rdr_names_w_locs = collectLocatedMonoBinders mbinds - gen_rdr_tyvars_w_locs = [(tv,src_loc) | tv <- extractGenericPatTyVars mbinds, - not (tv `elemRdrEnv` name_env)] - in - checkDupOrQualNames meth_doc meth_rdr_names_w_locs `thenM_` - newLocalsRn gen_rdr_tyvars_w_locs `thenM` \ gen_tyvars -> - rnMethodBinds cls gen_tyvars mbinds `thenM` \ (mbinds', meth_fvs) -> - returnM (rn_cls_decl {tcdMeths = Just mbinds'}, meth_fvs) - where - meth_doc = text "In the default-methods for class" <+> ppr (tcdName rn_cls_decl) - -finishSourceTyClDecl _ tycl_decl@(TyData {tcdDerivs = derivings}) - -- Derivings are returned here so that they don't form part of the tyClDeclFVs. - -- This is important, because tyClDeclFVs should contain only the - -- FVs that are `needed' by the interface file declaration, and - -- derivings do not appear in this. It also means that the tcGroups - -- are smaller, which turned out to be important for the usage inference. KSW 2002-02. - = returnM (tycl_decl, - maybe emptyFVs extractHsCtxtTyNames derivings) - -finishSourceTyClDecl _ tycl_decl = returnM (tycl_decl, emptyFVs) - -- Not a class declaration -\end{code} + extendTyVarEnvForMethodBinds tyvars' ( + getLocalRdrEnv `thenM` \ name_env -> + let + meth_rdr_names_w_locs = collectLocatedMonoBinders mbinds + gen_rdr_tyvars_w_locs = [(tv,src_loc) | tv <- extractGenericPatTyVars mbinds, + not (tv `elemLocalRdrEnv` name_env)] + in + checkDupNames meth_doc meth_rdr_names_w_locs `thenM_` + newLocalsRn gen_rdr_tyvars_w_locs `thenM` \ gen_tyvars -> + rnMethodBinds cname' gen_tyvars mbinds + ) `thenM` \ (mbinds', meth_fvs) -> -For the method bindings in class and instance decls, we extend the -type variable environment iff -fglasgow-exts - -\begin{code} -extendTyVarEnvForMethodBinds tyvars thing_inside - = doptM Opt_GlasgowExts `thenM` \ opt_GlasgowExts -> - if opt_GlasgowExts then - extendTyVarEnvFVRn (map hsTyVarName tyvars) thing_inside - else - thing_inside + returnM (ClassDecl { tcdCtxt = context', tcdName = cname', tcdTyVars = tyvars', + tcdFDs = fds', tcdSigs = sigs', tcdMeths = mbinds', + tcdLoc = src_loc}, + delFVs (map hsTyVarName tyvars') $ + extractHsCtxtTyNames context' `plusFV` + plusFVs (map extractFunDepNames fds') `plusFV` + hsSigsFVs sigs' `plusFV` + meth_fvs) + where + meth_doc = text "In the default-methods for class" <+> ppr cname + cls_doc = text "In the declaration for class" <+> ppr cname + sig_doc = text "In the signatures for class" <+> ppr cname \end{code} - %********************************************************* %* * \subsection{Support code for type/data declarations} @@ -684,22 +569,16 @@ extendTyVarEnvForMethodBinds tyvars thing_inside conDeclName :: RdrNameConDecl -> (RdrName, SrcLoc) conDeclName (ConDecl n _ _ _ l) = (n,l) -rnConDecls :: Name -> DataConDetails RdrNameConDecl -> RnM (DataConDetails RenamedConDecl) -rnConDecls tycon Unknown = returnM Unknown -rnConDecls tycon (HasCons n) = returnM (HasCons n) -rnConDecls tycon (DataCons condecls) +rnConDecls :: Name -> [RdrNameConDecl] -> RnM [RenamedConDecl] +rnConDecls tycon condecls = -- Check that there's at least one condecl, -- or else we're reading an interface file, or -fglasgow-exts (if null condecls then doptM Opt_GlasgowExts `thenM` \ glaExts -> - getModeRn `thenM` \ mode -> - checkErr (glaExts || isInterfaceMode mode) - (emptyConDeclsErr tycon) + checkErr glaExts (emptyConDeclsErr tycon) else returnM () ) `thenM_` - - mappM rnConDecl condecls `thenM` \ condecls' -> - returnM (DataCons condecls') + mappM rnConDecl condecls rnConDecl :: RdrNameConDecl -> RnM RenamedConDecl rnConDecl (ConDecl name tvs cxt details locn) @@ -724,7 +603,7 @@ rnConDetails doc locn (InfixCon ty1 ty2) returnM (InfixCon new_ty1 new_ty2) rnConDetails doc locn (RecCon fields) - = checkDupOrQualNames doc field_names `thenM_` + = checkDupNames doc field_names `thenM_` mappM (rnField doc) fields `thenM` \ new_fields -> returnM (RecCon new_fields) where @@ -749,8 +628,14 @@ rnBangTy doc (BangType s ty) -- data T = :% Int Int -- from interface files, which always print in prefix form -checkConName name - = checkErr (isRdrDataCon name) (badDataCon name) +checkConName name = checkErr (isRdrDataCon name) (badDataCon name) + +badDataCon name + = hsep [ptext SLIT("Illegal data constructor name"), quotes (ppr name)] + +emptyConDeclsErr tycon + = sep [quotes (ppr tycon) <+> ptext SLIT("has no constructors"), + nest 4 (ptext SLIT("(-fglasgow-exts permits this)"))] \end{code} @@ -775,217 +660,3 @@ rnHsTyVars doc tvs = mappM (rnHsTyvar doc) tvs rnHsTyvar doc tyvar = lookupOccRn tyvar \end{code} -%********************************************************* -%* * -\subsection{IdInfo} -%* * -%********************************************************* - -\begin{code} -rnIdInfo (HsWorker worker arity) - = lookupOccRn worker `thenM` \ worker' -> - returnM (HsWorker worker' arity) - -rnIdInfo (HsUnfold inline expr) = rnCoreExpr expr `thenM` \ expr' -> - returnM (HsUnfold inline expr') -rnIdInfo (HsStrictness str) = returnM (HsStrictness str) -rnIdInfo (HsArity arity) = returnM (HsArity arity) -rnIdInfo HsNoCafRefs = returnM HsNoCafRefs -\end{code} - -@UfCore@ expressions. - -\begin{code} -rnCoreExpr (UfType ty) - = rnHsType (text "unfolding type") ty `thenM` \ ty' -> - returnM (UfType ty') - -rnCoreExpr (UfVar v) - = lookupOccRn v `thenM` \ v' -> - returnM (UfVar v') - -rnCoreExpr (UfLit l) - = returnM (UfLit l) - -rnCoreExpr (UfFCall cc ty) - = rnHsType (text "ccall") ty `thenM` \ ty' -> - returnM (UfFCall cc ty') - -rnCoreExpr (UfTuple (HsTupCon boxity arity) args) - = mappM rnCoreExpr args `thenM` \ args' -> - returnM (UfTuple (HsTupCon boxity arity) args') - -rnCoreExpr (UfApp fun arg) - = rnCoreExpr fun `thenM` \ fun' -> - rnCoreExpr arg `thenM` \ arg' -> - returnM (UfApp fun' arg') - -rnCoreExpr (UfCase scrut bndr alts) - = rnCoreExpr scrut `thenM` \ scrut' -> - bindCoreLocalRn bndr $ \ bndr' -> - mappM rnCoreAlt alts `thenM` \ alts' -> - returnM (UfCase scrut' bndr' alts') - -rnCoreExpr (UfNote note expr) - = rnNote note `thenM` \ note' -> - rnCoreExpr expr `thenM` \ expr' -> - returnM (UfNote note' expr') - -rnCoreExpr (UfLam bndr body) - = rnCoreBndr bndr $ \ bndr' -> - rnCoreExpr body `thenM` \ body' -> - returnM (UfLam bndr' body') - -rnCoreExpr (UfLet (UfNonRec bndr rhs) body) - = rnCoreExpr rhs `thenM` \ rhs' -> - rnCoreBndr bndr $ \ bndr' -> - rnCoreExpr body `thenM` \ body' -> - returnM (UfLet (UfNonRec bndr' rhs') body') - -rnCoreExpr (UfLet (UfRec pairs) body) - = rnCoreBndrs bndrs $ \ bndrs' -> - mappM rnCoreExpr rhss `thenM` \ rhss' -> - rnCoreExpr body `thenM` \ body' -> - returnM (UfLet (UfRec (bndrs' `zip` rhss')) body') - where - (bndrs, rhss) = unzip pairs -\end{code} - -\begin{code} -rnCoreBndr (UfValBinder name ty) thing_inside - = rnHsType doc ty `thenM` \ ty' -> - bindCoreLocalRn name $ \ name' -> - thing_inside (UfValBinder name' ty') - where - doc = text "unfolding id" - -rnCoreBndr (UfTyBinder name kind) thing_inside - = bindCoreLocalRn name $ \ name' -> - thing_inside (UfTyBinder name' kind) - -rnCoreBndrs [] thing_inside = thing_inside [] -rnCoreBndrs (b:bs) thing_inside = rnCoreBndr b $ \ name' -> - rnCoreBndrs bs $ \ names' -> - thing_inside (name':names') -\end{code} - -\begin{code} -rnCoreAlt (con, bndrs, rhs) - = rnUfCon con `thenM` \ con' -> - bindCoreLocalsRn bndrs $ \ bndrs' -> - rnCoreExpr rhs `thenM` \ rhs' -> - returnM (con', bndrs', rhs') - -rnNote (UfCoerce ty) - = rnHsType (text "unfolding coerce") ty `thenM` \ ty' -> - returnM (UfCoerce ty') - -rnNote (UfSCC cc) = returnM (UfSCC cc) -rnNote UfInlineCall = returnM UfInlineCall -rnNote UfInlineMe = returnM UfInlineMe -rnNote (UfCoreNote s) = returnM (UfCoreNote s) - -rnUfCon UfDefault - = returnM UfDefault - -rnUfCon (UfTupleAlt tup_con) - = returnM (UfTupleAlt tup_con) - -rnUfCon (UfDataAlt con) - = lookupOccRn con `thenM` \ con' -> - returnM (UfDataAlt con') - -rnUfCon (UfLitAlt lit) - = returnM (UfLitAlt lit) -\end{code} - -%********************************************************* -%* * -\subsection{Statistics} -%* * -%********************************************************* - -\begin{code} -rnStats :: [RenamedHsDecl] -- Imported decls - -> TcRn m () -rnStats imp_decls - = doptM Opt_D_dump_rn_trace `thenM` \ dump_rn_trace -> - doptM Opt_D_dump_rn_stats `thenM` \ dump_rn_stats -> - doptM Opt_D_dump_rn `thenM` \ dump_rn -> - getEps `thenM` \ eps -> - - ioToTcRn (dumpIfSet (dump_rn_trace || dump_rn_stats || dump_rn) - "Renamer statistics" - (getRnStats eps imp_decls)) `thenM_` - returnM () - -getRnStats :: ExternalPackageState -> [RenamedHsDecl] -> SDoc -getRnStats eps imported_decls - = hcat [text "Renamer stats: ", stats] - where - n_mods = length [() | _ <- moduleEnvElts (eps_PIT eps)] - -- This is really only right for a one-shot compile - - (decls_map, n_decls_slurped) = eps_decls eps - - n_decls_left = length [decl | (avail, True, (_,decl)) <- nameEnvElts decls_map - -- Data, newtype, and class decls are in the decls_fm - -- under multiple names; the tycon/class, and each - -- constructor/class op too. - -- The 'True' selects just the 'main' decl - ] - - (insts_left, n_insts_slurped) = eps_insts eps - n_insts_left = length (bagToList insts_left) - - (rules_left, n_rules_slurped) = eps_rules eps - n_rules_left = length (bagToList rules_left) - - stats = vcat - [int n_mods <+> text "interfaces read", - hsep [ int n_decls_slurped, text "type/class/variable imported, out of", - int (n_decls_slurped + n_decls_left), text "read"], - hsep [ int n_insts_slurped, text "instance decls imported, out of", - int (n_insts_slurped + n_insts_left), text "read"], - hsep [ int n_rules_slurped, text "rule decls imported, out of", - int (n_rules_slurped + n_rules_left), text "read"] - ] -\end{code} - -%********************************************************* -%* * -\subsection{Errors} -%* * -%********************************************************* - -\begin{code} -badDataCon name - = hsep [ptext SLIT("Illegal data constructor name"), quotes (ppr name)] - -badRuleLhsErr name lhs (Just bad_e) - = sep [ptext SLIT("Rule") <+> ftext name <> colon, - nest 4 (vcat [ptext SLIT("Illegal expression:") <+> ppr bad_e, - ptext SLIT("in left-hand side:") <+> ppr lhs])] - $$ - ptext SLIT("LHS must be of form (f e1 .. en) where f is not forall'd") - -badRuleVar name var - = sep [ptext SLIT("Rule") <+> doubleQuotes (ftext name) <> colon, - ptext SLIT("Forall'd variable") <+> quotes (ppr var) <+> - ptext SLIT("does not appear on left hand side")] - -emptyConDeclsErr tycon - = sep [quotes (ppr tycon) <+> ptext SLIT("has no constructors"), - nest 4 (ptext SLIT("(-fglasgow-exts permits this)"))] - -withWarning - = sep [quotes (ptext SLIT("with")), - ptext SLIT("is deprecated, use"), - quotes (ptext SLIT("let")), - ptext SLIT("instead")] - -badIpBinds binds - = hang (ptext SLIT("Implicit-parameter bindings illegal in 'mdo':")) 4 - (ppr binds) -\end{code} - diff --git a/ghc/compiler/rename/RnTypes.lhs b/ghc/compiler/rename/RnTypes.lhs index 0125dab3bb..4b6f799cf5 100644 --- a/ghc/compiler/rename/RnTypes.lhs +++ b/ghc/compiler/rename/RnTypes.lhs @@ -11,19 +11,19 @@ module RnTypes ( rnHsType, rnContext, precParseErr, sectionPrecErr, dupFieldErr, patSigErr, checkTupSize ) where -import CmdLineOpts ( DynFlag(Opt_WarnMisc, Opt_WarnUnusedMatches, Opt_GlasgowExts) ) +import CmdLineOpts ( DynFlag(Opt_WarnUnusedMatches, Opt_GlasgowExts) ) import HsSyn import RdrHsSyn ( RdrNameContext, RdrNameHsType, RdrNamePat, - extractHsTyRdrTyVars, extractHsCtxtRdrTyVars ) + extractHsRhoRdrTyVars ) import RnHsSyn ( RenamedContext, RenamedHsType, RenamedPat, extractHsTyNames, parrTyCon_name, tupleTyCon_name, listTyCon_name, charTyCon_name ) import RnEnv ( lookupOccRn, lookupBndrRn, lookupSyntaxName, lookupGlobalOccRn, - newIPName, bindTyVarsRn, lookupFixityRn, mapFvRn, + bindTyVarsRn, lookupFixityRn, mapFvRn, newIPNameRn, bindPatSigTyVarsFV, bindLocalsFV, warnUnusedMatches ) import TcRnMonad - +import RdrName ( elemLocalRdrEnv ) import PrelNames( eqStringName, eqClassName, integralClassName, negateName, minusName, lengthPName, indexPName, plusIntegerName, fromIntegerName, timesIntegerName, ratioDataConName, fromRationalName ) @@ -31,15 +31,12 @@ import Constants ( mAX_TUPLE_SIZE ) import TysWiredIn ( intTyCon ) import TysPrim ( charPrimTyCon, addrPrimTyCon, intPrimTyCon, floatPrimTyCon, doublePrimTyCon ) -import RdrName ( elemRdrEnv ) import Name ( Name, NamedThing(..) ) import NameSet -import Unique ( Uniquable(..) ) import Literal ( inIntRange, inCharRange ) -import BasicTypes ( compareFixity, arrowFixity ) -import List ( nub ) -import ListSetOps ( removeDupsEq, removeDups ) +import BasicTypes ( compareFixity ) +import ListSetOps ( removeDups ) import Outputable #include "HsVersions.h" @@ -84,15 +81,13 @@ rnHsType doc (HsForAllTy Nothing ctxt ty) -- over FV(T) \ {in-scope-tyvars} = getLocalRdrEnv `thenM` \ name_env -> let - mentioned_in_tau = extractHsTyRdrTyVars ty - mentioned_in_ctxt = extractHsCtxtRdrTyVars ctxt - mentioned = nub (mentioned_in_tau ++ mentioned_in_ctxt) + mentioned = extractHsRhoRdrTyVars ctxt ty -- Don't quantify over type variables that are in scope; -- when GlasgowExts is off, there usually won't be any, except for -- class signatures: -- class C a where { op :: a -> a } - forall_tyvars = filter (not . (`elemRdrEnv` name_env)) mentioned + forall_tyvars = filter (not . (`elemLocalRdrEnv` name_env)) mentioned in rnForAll doc (map UserTyVar forall_tyvars) ctxt ty @@ -101,13 +96,11 @@ rnHsType doc (HsForAllTy (Just forall_tyvars) ctxt tau) -- Check that the forall'd tyvars are actually -- mentioned in the type, and produce a warning if not = let - mentioned_in_tau = extractHsTyRdrTyVars tau - mentioned_in_ctxt = extractHsCtxtRdrTyVars ctxt - mentioned = nub (mentioned_in_tau ++ mentioned_in_ctxt) - forall_tyvar_names = hsTyVarNames forall_tyvars + mentioned = extractHsRhoRdrTyVars ctxt tau + forall_tyvar_names = hsTyVarNames forall_tyvars -- Explicitly quantified but not mentioned in ctxt or tau - warn_guys = filter (`notElem` mentioned) forall_tyvar_names + warn_guys = filter (`notElem` mentioned) forall_tyvar_names in mappM_ (forAllWarn doc tau) warn_guys `thenM_` rnForAll doc forall_tyvars ctxt tau @@ -117,11 +110,7 @@ rnHsType doc (HsTyVar tyvar) returnM (HsTyVar tyvar') rnHsType doc (HsOpTy ty1 op ty2) - = (case op of - HsArrow -> returnM HsArrow - HsTyOp n -> lookupOccRn n `thenM` \ n' -> - returnM (HsTyOp n') - ) `thenM` \ op' -> + = lookupOccRn op `thenM` \ op' -> rnHsType doc ty1 `thenM` \ ty1' -> rnHsType doc ty2 `thenM` \ ty2' -> lookupTyFixityRn op' `thenM` \ fix -> @@ -202,14 +191,13 @@ have already been renamed and rearranged. It's made rather tiresome by the presence of -> \begin{code} -lookupTyFixityRn HsArrow = returnM arrowFixity -lookupTyFixityRn (HsTyOp n) +lookupTyFixityRn n = doptM Opt_GlasgowExts `thenM` \ glaExts -> warnIf (not glaExts) (infixTyConWarn n) `thenM_` lookupFixityRn n -- Building (ty1 `op1` (ty21 `op2` ty22)) -mkHsOpTyRn :: HsTyOp Name -> Fixity +mkHsOpTyRn :: Name -> Fixity -> RenamedHsType -> RenamedHsType -> RnM RenamedHsType @@ -232,13 +220,6 @@ mkHsOpTyRn op1 fix1 ty1 ty2@(HsOpTy ty21 op2 ty22) mkHsOpTyRn op fix ty1 ty2 -- Default case, no rearrangment = returnM (HsOpTy ty1 op ty2) - -mkHsFunTyRn ty1 ty2 -- Precedence of function arrow is 0 - = returnM (HsFunTy ty1 ty2) -- so no rearrangement reqd. Change - -- this if fixity of -> increases. - -not_op_ty (HsOpTy _ _ _) = False -not_op_ty other = True \end{code} %********************************************************* @@ -249,24 +230,7 @@ not_op_ty other = True \begin{code} rnContext :: SDoc -> RdrNameContext -> RnM RenamedContext -rnContext doc ctxt - = mappM rn_pred ctxt `thenM` \ theta -> - - -- Check for duplicate assertions - -- If this isn't an error, then it ought to be: - ifOptM Opt_WarnMisc ( - let - (_, dups) = removeDupsEq theta - -- We only have equality, not ordering - in - mappM_ (addWarn . dupClassAssertWarn theta) dups - ) `thenM_` - - returnM theta - where - rn_pred pred = rnPred doc pred `thenM` \ pred'-> - returnM pred' - +rnContext doc ctxt = mappM (rnPred doc) ctxt rnPred doc (HsClassP clas tys) = lookupOccRn clas `thenM` \ clas_name -> @@ -274,7 +238,7 @@ rnPred doc (HsClassP clas tys) returnM (HsClassP clas_name tys') rnPred doc (HsIParam n ty) - = newIPName n `thenM` \ name -> + = newIPNameRn n `thenM` \ name -> rnHsType doc ty `thenM` \ ty' -> returnM (HsIParam name ty') \end{code} @@ -419,17 +383,11 @@ rnConPat con (RecCon rpats) returnM (ConPatIn con' (RecCon rpats'), fvs `addOneFV` con') rnConPat con (InfixCon pat1 pat2) - = lookupOccRn con `thenM` \ con' -> - rnPat pat1 `thenM` \ (pat1', fvs1) -> - rnPat pat2 `thenM` \ (pat2', fvs2) -> - - getModeRn `thenM` \ mode -> - -- See comments with rnExpr (OpApp ...) - (if isInterfaceMode mode - then returnM (ConPatIn con' (InfixCon pat1' pat2')) - else lookupFixityRn con' `thenM` \ fixity -> - mkConOpPatRn con' fixity pat1' pat2' - ) `thenM` \ pat' -> + = lookupOccRn con `thenM` \ con' -> + rnPat pat1 `thenM` \ (pat1', fvs1) -> + rnPat pat2 `thenM` \ (pat2', fvs2) -> + lookupFixityRn con' `thenM` \ fixity -> + mkConOpPatRn con' fixity pat1' pat2' `thenM` \ pat' -> returnM (pat', fvs1 `plusFV` fvs2 `addOneFV` con') ------------------------ @@ -552,32 +510,11 @@ checkTupSize tup_size forAllWarn doc ty tyvar = ifOptM Opt_WarnUnusedMatches $ - getModeRn `thenM` \ mode -> - case mode of { -#ifndef DEBUG - InterfaceMode _ -> returnM () ; -- Don't warn of unused tyvars in interface files - -- unless DEBUG is on, in which case it is slightly - -- informative. They can arise from mkRhsTyLam, - -- leading to (say) f :: forall a b. [b] -> [b] -#endif - other -> - addWarn ( - sep [ptext SLIT("The universally quantified type variable") <+> quotes (ppr tyvar), + addWarn (sep [ptext SLIT("The universally quantified type variable") <+> quotes (ppr tyvar), nest 4 (ptext SLIT("does not appear in the type") <+> quotes (ppr ty))] $$ doc ) - } - -dupClassAssertWarn ctxt (assertion : dups) - = sep [hsep [ptext SLIT("Duplicate class assertion"), - quotes (ppr assertion), - ptext SLIT("in the context:")], - nest 4 (pprHsContext ctxt <+> ptext SLIT("..."))] - -naughtyCCallContextErr (HsClassP clas _) - = sep [ptext SLIT("Can't use class") <+> quotes (ppr clas), - ptext SLIT("in a context")] precParseErr op1 op2 = hang (ptext SLIT("precedence parsing error")) diff --git a/ghc/compiler/simplCore/SimplCore.lhs b/ghc/compiler/simplCore/SimplCore.lhs index 24f465b85b..af78fb7f4f 100644 --- a/ghc/compiler/simplCore/SimplCore.lhs +++ b/ghc/compiler/simplCore/SimplCore.lhs @@ -16,12 +16,12 @@ import CoreSyn import CoreFVs ( ruleRhsFreeVars ) import HscTypes ( HscEnv(..), GhciMode(..), ModGuts(..), ModGuts, Avails, availsToNameSet, - PackageRuleBase, HomePackageTable, ModDetails(..), - HomeModInfo(..) + ModDetails(..), + HomeModInfo(..), ExternalPackageState(..), hscEPS ) import CSE ( cseProgram ) -import Rules ( RuleBase, emptyRuleBase, ruleBaseFVs, ruleBaseIds, - extendRuleBaseList, addRuleBaseFVs, pprRuleBase, +import Rules ( RuleBase, emptyRuleBase, ruleBaseIds, + extendRuleBaseList, pprRuleBase, ruleCheckProgram ) import Module ( moduleEnvElts ) import Name ( Name, isExternalName ) @@ -65,17 +65,15 @@ import List ( partition ) \begin{code} core2core :: HscEnv - -> PackageRuleBase -> ModGuts -> IO ModGuts -core2core hsc_env pkg_rule_base +core2core hsc_env mod_impl@(ModGuts { mg_exports = exports, mg_binds = binds_in, mg_rules = rules_in }) = do let dflags = hsc_dflags hsc_env - hpt = hsc_HPT hsc_env ghci_mode = hsc_mode hsc_env core_todos | Just todo <- dopt_CoreToDo dflags = todo @@ -85,12 +83,12 @@ core2core hsc_env pkg_rule_base let (cp_us, ru_us) = splitUniqSupply us -- COMPUTE THE RULE BASE TO USE - (rule_base, local_rule_ids, orphan_rules, rule_rhs_fvs) - <- prepareRules dflags pkg_rule_base hpt ru_us binds_in rules_in + (rule_base, local_rule_ids, orphan_rules) + <- prepareRules hsc_env ru_us binds_in rules_in -- PREPARE THE BINDINGS let binds1 = updateBinders ghci_mode local_rule_ids - rule_rhs_fvs exports binds_in + orphan_rules exports binds_in -- DO THE BUSINESS (stats, processed_binds) @@ -216,17 +214,19 @@ noStats dfs thing = do { binds <- thing; return (zeroSimplCount dfs, binds) } -- so that the opportunity to apply the rule isn't lost too soon \begin{code} -prepareRules :: DynFlags -> PackageRuleBase -> HomePackageTable +prepareRules :: HscEnv -> UniqSupply -> [CoreBind] -> [IdCoreRule] -- Local rules -> IO (RuleBase, -- Full rule base IdSet, -- Local rule Ids - [IdCoreRule], -- Orphan rules - IdSet) -- RHS free vars of all rules + [IdCoreRule]) -- Orphan rules defined in this module -prepareRules dflags pkg_rule_base hpt us binds local_rules - = do { let env = emptySimplEnv SimplGently [] local_ids +prepareRules hsc_env@(HscEnv { hsc_dflags = dflags, hsc_HPT = hpt }) + us binds local_rules + = do { eps <- hscEPS hsc_env + + ; let env = emptySimplEnv SimplGently [] local_ids (better_rules,_) = initSmpl dflags us (mapSmpl (simplRule env) local_rules) ; let (local_rules, orphan_rules) = partition ((`elemVarSet` local_ids) . fst) better_rules @@ -239,21 +239,18 @@ prepareRules dflags pkg_rule_base hpt us binds local_rules -- Example: class Foo a where -- op :: a -> a -- {-# RULES "op" op x = x #-} + local_rule_base = extendRuleBaseList emptyRuleBase local_rules + local_rule_ids = ruleBaseIds local_rule_base -- Local Ids with rules attached - rule_rhs_fvs = unionVarSets (map (ruleRhsFreeVars . snd) better_rules) - local_rule_base = extendRuleBaseList emptyRuleBase local_rules - local_rule_ids = ruleBaseIds local_rule_base -- Local Ids with rules attached - imp_rule_base = foldl add_rules pkg_rule_base (moduleEnvElts hpt) - rule_base = extendRuleBaseList imp_rule_base orphan_rules - final_rule_base = addRuleBaseFVs rule_base (ruleBaseFVs local_rule_base) - -- The last step black-lists the free vars of local rules too + imp_rule_base = foldl add_rules (eps_rule_base eps) (moduleEnvElts hpt) + final_rule_base = extendRuleBaseList imp_rule_base orphan_rules ; dumpIfSet_dyn dflags Opt_D_dump_rules "Transformation rules" (vcat [text "Local rules", pprRuleBase local_rule_base, text "", text "Imported rules", pprRuleBase final_rule_base]) - ; return (final_rule_base, local_rule_ids, orphan_rules, rule_rhs_fvs) + ; return (final_rule_base, local_rule_ids, orphan_rules) } where add_rules rule_base mod_info = extendRuleBaseList rule_base (md_rules (hm_details mod_info)) @@ -264,7 +261,7 @@ prepareRules dflags pkg_rule_base hpt us binds local_rules updateBinders :: GhciMode -> IdSet -- Locally defined ids with their Rules attached - -> IdSet -- Ids free in the RHS of local rules + -> [IdCoreRule] -- Orphan rules -> Avails -- What is exported -> [CoreBind] -> [CoreBind] -- A horrible function @@ -294,7 +291,7 @@ updateBinders :: GhciMode -- the rules (maybe we should?), so this substitution would make the rule -- bogus. -updateBinders ghci_mode rule_ids rule_rhs_fvs exports binds +updateBinders ghci_mode rule_ids orphan_rules exports binds = map update_bndrs binds where update_bndrs (NonRec b r) = NonRec (update_bndr b) r @@ -306,8 +303,14 @@ updateBinders ghci_mode rule_ids rule_rhs_fvs exports binds where bndr_with_rules = lookupVarSet rule_ids bndr `orElse` bndr + orph_rhs_fvs = unionVarSets (map (ruleRhsFreeVars . snd) orphan_rules) + -- An orphan rule must keep alive the free vars + -- of its right-hand side. + -- Non-orphan rules are attached to the Id (bndr_with_rules above) + -- and that keeps the rhs free vars alive + dont_discard bndr = is_exported (idName bndr) - || bndr `elemVarSet` rule_rhs_fvs + || bndr `elemVarSet` orph_rhs_fvs -- In interactive mode, we don't want to discard any top-level -- entities at all (eg. do not inline them away during diff --git a/ghc/compiler/specialise/Rules.lhs b/ghc/compiler/specialise/Rules.lhs index 34813e7c49..4f9c24d01c 100644 --- a/ghc/compiler/specialise/Rules.lhs +++ b/ghc/compiler/specialise/Rules.lhs @@ -6,8 +6,8 @@ \begin{code} module Rules ( RuleBase, emptyRuleBase, - extendRuleBase, extendRuleBaseList, addRuleBaseFVs, - ruleBaseIds, ruleBaseFVs, + extendRuleBase, extendRuleBaseList, + ruleBaseIds, pprRuleBase, ruleCheckProgram, lookupRule, addRule, addIdSpecialisations @@ -17,7 +17,7 @@ module Rules ( import CoreSyn -- All of it import OccurAnal ( occurAnalyseRule ) -import CoreFVs ( exprFreeVars, ruleRhsFreeVars, ruleLhsFreeIds ) +import CoreFVs ( exprFreeVars, ruleRhsFreeVars ) import CoreUnfold ( isCheapUnfolding, unfoldingTemplate ) import CoreUtils ( eqExpr ) import CoreTidy ( pprTidyIdRules ) @@ -373,14 +373,6 @@ bind vs1 vs2 matcher tpl_vars kont subst bug_msg = sep [ppr vs1, ppr vs2] ---------------------------------------- -matches [] [] tpl_vars kont subst - = kont subst -matches (e:es) (e':es') tpl_vars kont subst - = match e e' tpl_vars (matches es es' tpl_vars kont) subst -matches es es' tpl_vars kont subst - = match_fail - ----------------------------------------- mkVarArg :: CoreBndr -> CoreArg mkVarArg v | isId v = Var v | otherwise = Type (mkTyVarTy v) @@ -594,43 +586,27 @@ data RuleBase = RuleBase IdSet -- Ids with their rules in their specialisations -- Held as a set, so that it can simply be the initial -- in-scope set in the simplifier - - IdSet -- Ids (whether local or imported) mentioned on - -- LHS of some rule; these should be black listed - -- This representation is a bit cute, and I wonder if we should -- change it to use (IdEnv CoreRule) which seems a bit more natural -ruleBaseIds (RuleBase ids _) = ids -ruleBaseFVs (RuleBase _ fvs) = fvs - -emptyRuleBase = RuleBase emptyVarSet emptyVarSet - -addRuleBaseFVs :: RuleBase -> IdSet -> RuleBase -addRuleBaseFVs (RuleBase rules fvs) extra_fvs - = RuleBase rules (fvs `unionVarSet` extra_fvs) +ruleBaseIds (RuleBase ids) = ids +emptyRuleBase = RuleBase emptyVarSet extendRuleBaseList :: RuleBase -> [(Id,CoreRule)] -> RuleBase extendRuleBaseList rule_base new_guys = foldl extendRuleBase rule_base new_guys extendRuleBase :: RuleBase -> (Id,CoreRule) -> RuleBase -extendRuleBase (RuleBase rule_ids rule_fvs) (id, rule) +extendRuleBase (RuleBase rule_ids) (id, rule) = RuleBase (extendVarSet rule_ids new_id) - (rule_fvs `unionVarSet` extendVarSet lhs_fvs id) where - new_id = setIdSpecialisation id (addRule id old_rules rule) - + new_id = setIdSpecialisation id (addRule id old_rules rule) old_rules = idSpecialisation (fromMaybe id (lookupVarSet rule_ids id)) -- Get the old rules from rule_ids if the Id is already there, but -- if not, use the Id from the incoming rule. If may be a PrimOpId, -- in which case it may have rules in its belly already. Seems -- dreadfully hackoid. - lhs_fvs = ruleLhsFreeIds rule - -- Finds *all* the free Ids of the LHS, not just - -- locally defined ones!! - pprRuleBase :: RuleBase -> SDoc -pprRuleBase (RuleBase rules _) = vcat [ pprTidyIdRules id | id <- varSetElems rules ] +pprRuleBase (RuleBase rules) = vcat [ pprTidyIdRules id | id <- varSetElems rules ] \end{code} diff --git a/ghc/compiler/stgSyn/CoreToStg.lhs b/ghc/compiler/stgSyn/CoreToStg.lhs index 8fdc00398f..3291c0df4c 100644 --- a/ghc/compiler/stgSyn/CoreToStg.lhs +++ b/ghc/compiler/stgSyn/CoreToStg.lhs @@ -860,15 +860,7 @@ thenLne :: LneM a -> (a -> LneM b) -> LneM b thenLne m k env lvs_cont = k (m env lvs_cont) env lvs_cont -mapLne :: (a -> LneM b) -> [a] -> LneM [b] -mapLne f [] = returnLne [] -mapLne f (x:xs) - = f x `thenLne` \ r -> - mapLne f xs `thenLne` \ rs -> - returnLne (r:rs) - mapAndUnzipLne :: (a -> LneM (b,c)) -> [a] -> LneM ([b],[c]) - mapAndUnzipLne f [] = returnLne ([],[]) mapAndUnzipLne f (x:xs) = f x `thenLne` \ (r1, r2) -> @@ -876,7 +868,6 @@ mapAndUnzipLne f (x:xs) returnLne (r1:rs1, r2:rs2) mapAndUnzip3Lne :: (a -> LneM (b,c,d)) -> [a] -> LneM ([b],[c],[d]) - mapAndUnzip3Lne f [] = returnLne ([],[],[]) mapAndUnzip3Lne f (x:xs) = f x `thenLne` \ (r1, r2, r3) -> @@ -884,7 +875,6 @@ mapAndUnzip3Lne f (x:xs) returnLne (r1:rs1, r2:rs2, r3:rs3) mapAndUnzip4Lne :: (a -> LneM (b,c,d,e)) -> [a] -> LneM ([b],[c],[d],[e]) - mapAndUnzip4Lne f [] = returnLne ([],[],[],[]) mapAndUnzip4Lne f (x:xs) = f x `thenLne` \ (r1, r2, r3, r4) -> diff --git a/ghc/compiler/stgSyn/StgLint.lhs b/ghc/compiler/stgSyn/StgLint.lhs index f634185c0c..31cc98afce 100644 --- a/ghc/compiler/stgSyn/StgLint.lhs +++ b/ghc/compiler/stgSyn/StgLint.lhs @@ -23,11 +23,11 @@ import ErrUtils ( Message, addErrLocHdrLine ) import Type ( mkFunTys, splitFunTys, splitTyConApp_maybe, isUnLiftedType, isTyVarTy, dropForAlls, Type ) -import TyCon ( TyCon, isAlgTyCon, isNewTyCon, tyConDataCons ) +import TyCon ( isAlgTyCon, isNewTyCon, tyConDataCons ) import Util ( zipEqual, equalLength ) import Outputable -infixr 9 `thenL`, `thenL_`, `thenMaybeL`, `thenMaybeL_` +infixr 9 `thenL`, `thenL_`, `thenMaybeL` \end{code} Checks for @@ -345,12 +345,6 @@ thenMaybeL m k loc scope errs (Nothing, errs2) -> (Nothing, errs2) (Just r, errs2) -> k r loc scope errs2 -thenMaybeL_ :: LintM (Maybe a) -> LintM (Maybe b) -> LintM (Maybe b) -thenMaybeL_ m k loc scope errs - = case m loc scope errs of - (Nothing, errs2) -> (Nothing, errs2) - (Just _, errs2) -> k loc scope errs2 - mapL :: (a -> LintM b) -> [a] -> LintM [b] mapL f [] = returnL [] mapL f (x:xs) @@ -461,11 +455,6 @@ mkCaseAltMsg alts = ($$) (text "In some case alternatives, type of alternatives not all same:") (empty) -- LATER: ppr alts -mkCaseAbstractMsg :: TyCon -> Message -mkCaseAbstractMsg tycon - = ($$) (ptext SLIT("An algebraic case on an abstract type:")) - (ppr tycon) - mkDefltMsg :: Id -> Message mkDefltMsg bndr = ($$) (ptext SLIT("Binder of a case expression doesn't match type of scrutinee:")) @@ -484,12 +473,6 @@ mkRhsConMsg fun_ty arg_tys hang (ptext SLIT("Constructor type:")) 4 (ppr fun_ty), hang (ptext SLIT("Arg types:")) 4 (vcat (map (ppr) arg_tys))] -mkUnappTyMsg :: Id -> Type -> Message -mkUnappTyMsg var ty - = vcat [text "Variable has a for-all type, but isn't applied to any types.", - (<>) (ptext SLIT("Var: ")) (ppr var), - (<>) (ptext SLIT("Its type: ")) (ppr ty)] - mkAltMsg1 :: Type -> Message mkAltMsg1 ty = ($$) (text "In a case expression, type of scrutinee does not match patterns") diff --git a/ghc/compiler/stgSyn/StgSyn.lhs b/ghc/compiler/stgSyn/StgSyn.lhs index ed1dacfb24..156e8dbada 100644 --- a/ghc/compiler/stgSyn/StgSyn.lhs +++ b/ghc/compiler/stgSyn/StgSyn.lhs @@ -56,6 +56,7 @@ import Literal ( Literal, literalType, literalPrimRep ) import ForeignCall ( ForeignCall ) import DataCon ( DataCon, dataConName ) import CoreSyn ( AltCon ) +import PprCore ( {- instances -} ) import PrimOp ( PrimOp ) import Outputable import Util ( count ) diff --git a/ghc/compiler/stranal/DmdAnal.lhs b/ghc/compiler/stranal/DmdAnal.lhs index b27a30ee2b..fe588f0131 100644 --- a/ghc/compiler/stranal/DmdAnal.lhs +++ b/ghc/compiler/stranal/DmdAnal.lhs @@ -55,10 +55,6 @@ To think about * Consider f x = x+1 `fatbar` error (show x) We'd like to unbox x, even if that means reboxing it in the error case. -\begin{code} -instance Outputable TopLevelFlag where - ppr flag = empty -\end{code} %************************************************************************ %* * @@ -886,17 +882,6 @@ argDemand d = d \end{code} \begin{code} -betterStrictness :: StrictSig -> StrictSig -> Bool -betterStrictness (StrictSig t1) (StrictSig t2) = betterDmdType t1 t2 - -betterDmdType t1 t2 = (t1 `lubType` t2) == t2 - -betterDemand :: Demand -> Demand -> Bool --- If d1 `better` d2, and d2 `better` d2, then d1==d2 -betterDemand d1 d2 = (d1 `lub` d2) == d2 -\end{code} - -\begin{code} ------------------------- -- Consider (if x then y else []) with demand V -- Then the first branch gives {y->V} and the second @@ -1166,7 +1151,15 @@ get_changes_dmd id old = newDemand (idDemandInfo id) new_better = new `betterDemand` old old_better = old `betterDemand` new -#endif + +betterStrictness :: StrictSig -> StrictSig -> Bool +betterStrictness (StrictSig t1) (StrictSig t2) = betterDmdType t1 t2 + +betterDmdType t1 t2 = (t1 `lubType` t2) == t2 + +betterDemand :: Demand -> Demand -> Bool +-- If d1 `better` d2, and d2 `better` d2, then d1==d2 +betterDemand d1 d2 = (d1 `lub` d2) == d2 squashSig (StrictSig (DmdType fv ds res)) = StrictSig (DmdType emptyDmdEnv (map squashDmd ds) res) @@ -1178,4 +1171,5 @@ squashDmd (Box d) = Box (squashDmd d) squashDmd (Eval ds) = Eval (mapDmds squashDmd ds) squashDmd (Defer ds) = Defer (mapDmds squashDmd ds) squashDmd d = d +#endif \end{code} diff --git a/ghc/compiler/stranal/WorkWrap.lhs b/ghc/compiler/stranal/WorkWrap.lhs index d587894ac3..8b889970c9 100644 --- a/ghc/compiler/stranal/WorkWrap.lhs +++ b/ghc/compiler/stranal/WorkWrap.lhs @@ -228,7 +228,6 @@ tryWW is_rec fn_id rhs maybe_fn_dmd = newDemandInfo fn_info unfolding = unfoldingInfo fn_info inline_prag = inlinePragInfo fn_info - maybe_sig = newStrictnessInfo fn_info -- In practice it always will have a strictness -- signature, even if it's a uninformative one diff --git a/ghc/compiler/stranal/WwLib.lhs b/ghc/compiler/stranal/WwLib.lhs index 49571f3087..e1a1da6463 100644 --- a/ghc/compiler/stranal/WwLib.lhs +++ b/ghc/compiler/stranal/WwLib.lhs @@ -20,7 +20,7 @@ import NewDemand ( Demand(..), DmdResult(..), Demands(..) ) import MkId ( realWorldPrimId, voidArgId, mkRuntimeErrorApp, rUNTIME_ERROR_ID ) import TysWiredIn ( tupleCon ) import Type ( Type, isUnLiftedType, mkFunTys, - splitForAllTys, splitFunTys, splitNewType_maybe, isAlgType + splitForAllTys, splitFunTys, splitRecNewType_maybe, isAlgType ) import BasicTypes ( Boxity(..) ) import Var ( Var, isId ) @@ -223,7 +223,7 @@ mkWWargs :: Type Type) -- Type of wrapper body mkWWargs fun_ty demands one_shots - | Just rep_ty <- splitNewType_maybe fun_ty + | Just rep_ty <- splitRecNewType_maybe fun_ty -- The newtype case is for when the function has -- a recursive newtype after the arrow (rare) -- We check for arity >= 0 to avoid looping in the case diff --git a/ghc/compiler/typecheck/Inst.lhs b/ghc/compiler/typecheck/Inst.lhs index 61bfd6018a..2a2663a8b7 100644 --- a/ghc/compiler/typecheck/Inst.lhs +++ b/ghc/compiler/typecheck/Inst.lhs @@ -10,7 +10,8 @@ module Inst ( showLIE, Inst, - pprInst, pprInsts, pprInstsInFull, tidyInsts, tidyMoreInsts, + pprInst, pprInsts, pprInstsInFull, pprDFuns, + tidyInsts, tidyMoreInsts, newDictsFromOld, newDicts, cloneDict, newOverloadedLit, newIPDict, @@ -23,6 +24,7 @@ module Inst ( instLoc, getDictClassTys, dictPred, lookupInst, LookupInstResult(..), + tcExtendLocalInstEnv, tcGetInstEnvs, isDict, isClassDict, isMethod, isLinearInst, linearInstType, isIPDict, isInheritableInst, @@ -45,15 +47,16 @@ import TcHsSyn ( TcExpr, TcId, TcIdSet, mkCoercion, ExprCoFn ) import TcRnMonad -import TcEnv ( tcGetInstEnv, tcLookupId, tcLookupTyCon, checkWellStaged, topIdLvl ) -import InstEnv ( InstLookupResult(..), lookupInstEnv ) +import TcEnv ( tcLookupId, checkWellStaged, topIdLvl, tcMetaTy ) +import InstEnv ( DFunId, InstEnv, lookupInstEnv, checkFunDeps, extendInstEnv ) +import TcIface ( loadImportedInsts ) import TcMType ( zonkTcType, zonkTcTypes, zonkTcPredType, zonkTcThetaType, tcInstTyVar, tcInstType, tcInstTyVars ) import TcType ( Type, TcType, TcThetaType, TcTyVarSet, - SourceType(..), PredType, TyVarDetails(VanillaTv), + PredType(..), TyVarDetails(VanillaTv), tcSplitForAllTys, tcSplitForAllTys, mkTyConApp, - tcSplitPhiTy, mkGenTyConApp, + tcSplitPhiTy, isTyVarTy, tcSplitDFunTy, isIntTy,isFloatTy, isIntegerTy, isDoubleTy, tcIsTyVarTy, mkPredTy, mkTyVarTy, mkTyVarTys, tyVarsOfType, tyVarsOfTypes, tyVarsOfPred, tidyPred, @@ -62,19 +65,21 @@ import TcType ( Type, TcType, TcThetaType, TcTyVarSet, isInheritablePred, isIPPred, tidyType, tidyTypes, tidyFreeTyVars, tcSplitSigmaTy ) +import HscTypes ( ExternalPackageState(..) ) import CoreFVs ( idFreeTyVars ) import DataCon ( DataCon,dataConSig ) import Id ( Id, idName, idType, mkUserLocal, mkSysLocal, mkLocalId, setIdUnique ) import PrelInfo ( isStandardClass, isNoDictClass ) -import Name ( Name, mkMethodOcc, getOccName ) -import PprType ( pprPred, pprParendType ) +import Name ( Name, mkMethodOcc, getOccName, getSrcLoc, isHomePackageName, isInternalName ) +import NameSet ( addOneToNameSet ) +import PprType ( pprPred, pprParendType, pprThetaArrow, pprClassPred ) import Subst ( substTy, substTyWith, substTheta, mkTyVarSubst ) import Literal ( inIntRange ) import Var ( TyVar ) import VarEnv ( TidyEnv, emptyTidyEnv, lookupSubstEnv, SubstResult(..) ) import VarSet ( elemVarSet, emptyVarSet, unionVarSet ) import TysWiredIn ( floatDataCon, doubleDataCon ) -import PrelNames( fromIntegerName, fromRationalName, rationalTyConName ) +import PrelNames ( integerTyConName, fromIntegerName, fromRationalName, rationalTyConName ) import BasicTypes( IPName(..), mapIPName, ipNameName ) import UniqSupply( uniqsFromSupply ) import Outputable @@ -358,7 +363,8 @@ newOverloadedLit orig lit@(HsIntegral i fi) expected_ty -- syntax. Reason: tcSyntaxName does unification -- which is very inconvenient in tcSimplify = tcSyntaxName orig expected_ty (fromIntegerName, HsVar fi) `thenM` \ (_,expr) -> - returnM (HsApp expr (HsLit (HsInteger i))) + mkIntegerLit i `thenM` \ integer_lit -> + returnM (HsApp expr integer_lit) | Just expr <- shortCutIntLit i expected_ty = returnM expr @@ -390,10 +396,10 @@ newLitInst orig lit expected_ty shortCutIntLit :: Integer -> TcType -> Maybe TcExpr shortCutIntLit i ty - | isIntTy ty && inIntRange i -- Short cut for Int + | isIntTy ty && inIntRange i -- Short cut for Int = Just (HsLit (HsInt i)) - | isIntegerTy ty -- Short cut for Integer - = Just (HsLit (HsInteger i)) + | isIntegerTy ty -- Short cut for Integer + = Just (HsLit (HsInteger i ty)) | otherwise = Nothing shortCutFracLit :: Rational -> TcType -> Maybe TcExpr @@ -404,13 +410,15 @@ shortCutFracLit f ty = Just (mkHsConApp doubleDataCon [] [HsLit (HsDoublePrim f)]) | otherwise = Nothing +mkIntegerLit :: Integer -> TcM TcExpr +mkIntegerLit i + = tcMetaTy integerTyConName `thenM` \ integer_ty -> + returnM (HsLit (HsInteger i integer_ty)) + mkRatLit :: Rational -> TcM TcExpr mkRatLit r - = tcLookupTyCon rationalTyConName `thenM` \ rat_tc -> - let - rational_ty = mkGenTyConApp rat_tc [] - in - returnM (HsLit (HsRat r rational_ty)) + = tcMetaTy rationalTyConName `thenM` \ rat_ty -> + returnM (HsLit (HsRat r rat_ty)) \end{code} @@ -483,6 +491,16 @@ pprInst m@(Method u id tys theta tau loc) show_uniq u, ppr (instToId m) -}] + +pprDFuns :: [DFunId] -> SDoc +-- Prints the dfun as an instance declaration +pprDFuns dfuns = vcat [ hang (ppr (getSrcLoc dfun) <> colon) + 2 (ptext SLIT("instance") <+> sep [pprThetaArrow theta, + pprClassPred clas tys]) + | dfun <- dfuns + , let (_, theta, clas, tys) = tcSplitDFunTy (idType dfun) ] + -- Print without the for-all, which the programmer doesn't write + show_uniq u = ifPprDebug (text "{-" <> ppr u <> text "-}") tidyInst :: TidyEnv -> Inst -> Inst @@ -511,6 +529,43 @@ showLIE str %************************************************************************ %* * + Extending the instance environment +%* * +%************************************************************************ + +\begin{code} +tcExtendLocalInstEnv :: [DFunId] -> TcM a -> TcM a + -- Add new locally-defined instances +tcExtendLocalInstEnv dfuns thing_inside + = do { traceDFuns dfuns + ; eps <- getEps + ; env <- getGblEnv + ; inst_env' <- foldlM (extend (eps_inst_env eps)) + (tcg_inst_env env) + dfuns + ; let env' = env { tcg_insts = dfuns ++ tcg_insts env, + tcg_inst_env = inst_env' } + ; setGblEnv env' thing_inside } + where + extend pkg_ie home_ie dfun + = do { case checkFunDeps (home_ie, pkg_ie) dfun of + Just dfuns -> funDepErr dfun dfuns + Nothing -> return () + ; return (extendInstEnv home_ie dfun) } + +traceDFuns dfuns + = traceTc (text "Adding instances:" <+> vcat (map pp dfuns)) + where + pp dfun = ppr dfun <+> dcolon <+> ppr (idType dfun) + +funDepErr dfun dfuns + = addSrcLoc (getSrcLoc dfun) $ + addErr (hang (ptext SLIT("Functional dependencies conflict between instance declarations:")) + 2 (pprDFuns (dfun:dfuns))) +\end{code} + +%************************************************************************ +%* * \subsection{Looking up Insts} %* * %************************************************************************ @@ -527,48 +582,6 @@ lookupInst :: Inst -> TcM (LookupInstResult s) -- the LookupInstResult, where they can be further processed by tcSimplify --- Dictionaries -lookupInst dict@(Dict _ pred@(ClassP clas tys) loc) - = getDOpts `thenM` \ dflags -> - tcGetInstEnv `thenM` \ inst_env -> - case lookupInstEnv dflags inst_env clas tys of - - FoundInst tenv dfun_id - -> -- It's possible that not all the tyvars are in - -- the substitution, tenv. For example: - -- instance C X a => D X where ... - -- (presumably there's a functional dependency in class C) - -- Hence the mk_ty_arg to instantiate any un-substituted tyvars. - getStage `thenM` \ use_stage -> - checkWellStaged (ptext SLIT("instance for") <+> quotes (ppr pred)) - (topIdLvl dfun_id) use_stage `thenM_` - traceTc (text "lookupInst" <+> ppr dfun_id <+> ppr (topIdLvl dfun_id) <+> ppr use_stage) `thenM_` - let - (tyvars, rho) = tcSplitForAllTys (idType dfun_id) - mk_ty_arg tv = case lookupSubstEnv tenv tv of - Just (DoneTy ty) -> returnM ty - Nothing -> tcInstTyVar VanillaTv tv `thenM` \ tc_tv -> - returnM (mkTyVarTy tc_tv) - in - mappM mk_ty_arg tyvars `thenM` \ ty_args -> - let - dfun_rho = substTy (mkTyVarSubst tyvars ty_args) rho - (theta, _) = tcSplitPhiTy dfun_rho - ty_app = mkHsTyApp (HsVar dfun_id) ty_args - in - if null theta then - returnM (SimpleInst ty_app) - else - newDictsAtLoc loc theta `thenM` \ dicts -> - let - rhs = mkHsDictApp ty_app (map instToId dicts) - in - returnM (GenInst dicts rhs) - - other -> returnM NoInstance - -lookupInst (Dict _ _ _) = returnM NoInstance - -- Methods lookupInst inst@(Method _ id tys theta _ loc) @@ -592,9 +605,9 @@ lookupInst inst@(LitInst u (HsIntegral i from_integer_name) ty loc) = ASSERT( from_integer_name == fromIntegerName ) -- A LitInst invariant tcLookupId fromIntegerName `thenM` \ from_integer -> tcInstClassOp loc from_integer [ty] `thenM` \ method_inst -> + mkIntegerLit i `thenM` \ integer_lit -> returnM (GenInst [method_inst] - (HsApp (HsVar (instToId method_inst)) (HsLit (HsInteger i)))) - + (HsApp (HsVar (instToId method_inst)) integer_lit)) lookupInst inst@(LitInst u (HsFractional f from_rat_name) ty loc) | Just expr <- shortCutFracLit f ty @@ -606,6 +619,78 @@ lookupInst inst@(LitInst u (HsFractional f from_rat_name) ty loc) tcInstClassOp loc from_rational [ty] `thenM` \ method_inst -> mkRatLit f `thenM` \ rat_lit -> returnM (GenInst [method_inst] (HsApp (HsVar (instToId method_inst)) rat_lit)) + +-- Dictionaries +lookupInst dict@(Dict _ pred@(ClassP clas tys) loc) + | all isTyVarTy tys -- Common special case; no lookup + = returnM NoInstance + + | otherwise + = do { pkg_ie <- loadImportedInsts clas tys + -- Suck in any instance decls that may be relevant + ; tcg_env <- getGblEnv + ; dflags <- getDOpts + ; case lookupInstEnv dflags (pkg_ie, tcg_inst_env tcg_env) clas tys of { + ([(tenv, (_,_,dfun_id))], []) -> instantiate_dfun tenv dfun_id pred loc ; + other -> return NoInstance } } + -- In the case of overlap (multiple matches) we report + -- NoInstance here. That has the effect of making the + -- context-simplifier return the dict as an irreducible one. + -- Then it'll be given to addNoInstanceErrs, which will do another + -- lookupInstEnv to get the detailed info about what went wrong. + +lookupInst (Dict _ _ _) = returnM NoInstance + +----------------- +instantiate_dfun tenv dfun_id pred loc + = -- Record that this dfun is needed + record_dfun_usage dfun_id `thenM_` + + -- It's possible that not all the tyvars are in + -- the substitution, tenv. For example: + -- instance C X a => D X where ... + -- (presumably there's a functional dependency in class C) + -- Hence the mk_ty_arg to instantiate any un-substituted tyvars. + getStage `thenM` \ use_stage -> + checkWellStaged (ptext SLIT("instance for") <+> quotes (ppr pred)) + (topIdLvl dfun_id) use_stage `thenM_` + traceTc (text "lookupInst" <+> ppr dfun_id <+> ppr (topIdLvl dfun_id) <+> ppr use_stage) `thenM_` + let + (tyvars, rho) = tcSplitForAllTys (idType dfun_id) + mk_ty_arg tv = case lookupSubstEnv tenv tv of + Just (DoneTy ty) -> returnM ty + Nothing -> tcInstTyVar VanillaTv tv `thenM` \ tc_tv -> + returnM (mkTyVarTy tc_tv) + in + mappM mk_ty_arg tyvars `thenM` \ ty_args -> + let + dfun_rho = substTy (mkTyVarSubst tyvars ty_args) rho + (theta, _) = tcSplitPhiTy dfun_rho + ty_app = mkHsTyApp (HsVar dfun_id) ty_args + in + if null theta then + returnM (SimpleInst ty_app) + else + newDictsAtLoc loc theta `thenM` \ dicts -> + let + rhs = mkHsDictApp ty_app (map instToId dicts) + in + returnM (GenInst dicts rhs) + +record_dfun_usage dfun_id + | isInternalName dfun_name = return () -- From this module + | not (isHomePackageName dfun_name) = return () -- From another package package + | otherwise = getGblEnv `thenM` \ tcg_env -> + updMutVar (tcg_inst_uses tcg_env) + (`addOneToNameSet` idName dfun_id) + where + dfun_name = idName dfun_id + +tcGetInstEnvs :: TcM (InstEnv, InstEnv) +-- Gets both the home-pkg inst env (includes module being compiled) +-- and the external-package inst-env +tcGetInstEnvs = do { eps <- getEps; env <- getGblEnv; + return (tcg_inst_env env, eps_inst_env eps) } \end{code} @@ -662,6 +747,9 @@ tcSyntaxName orig ty (std_nm, user_nm_expr) -- case of locally-polymorphic methods. in addErrCtxtM (syntaxNameCtxt user_nm_expr orig tau1) $ + + -- Check that the user-supplied thing has the + -- same type as the standard one tcCheckSigma user_nm_expr tau1 `thenM` \ expr -> returnM (std_nm, expr) diff --git a/ghc/compiler/typecheck/TcArrows.lhs b/ghc/compiler/typecheck/TcArrows.lhs index 77c7165bcb..eda193a095 100644 --- a/ghc/compiler/typecheck/TcArrows.lhs +++ b/ghc/compiler/typecheck/TcArrows.lhs @@ -11,14 +11,14 @@ module TcArrows ( tcProc ) where import {-# SOURCE #-} TcExpr( tcCheckRho ) import HsSyn -import TcHsSyn ( TcCmd, TcCmdTop, TcExpr, TcPat, mkHsLet ) +import TcHsSyn ( TcCmdTop, TcExpr, TcPat, mkHsLet ) import TcMatches ( TcStmtCtxt(..), tcMatchPats, matchCtxt, tcStmts, TcMatchCtxt(..), tcMatchesCase ) import TcType ( TcType, TcTauType, TcRhoType, mkFunTys, mkTyConApp, mkTyVarTy, mkAppTys, tcSplitTyConApp_maybe, tcEqType ) -import TcMType ( newTyVar, newTyVarTy, newTyVarTys, newSigTyVar, zonkTcType ) +import TcMType ( newTyVarTy, newTyVarTys, newSigTyVar, zonkTcType ) import TcBinds ( tcBindsAndThen ) import TcSimplify ( tcSimplifyCheck ) import TcUnify ( Expected(..), checkSigTyVarsWrt, zapExpectedTo ) @@ -28,7 +28,7 @@ import TysWiredIn ( boolTy, pairTyCon ) import VarSet import Type ( Kind, mkArrowKinds, liftedTypeKind, openTypeKind, tyVarsOfTypes ) -import RnHsSyn ( RenamedHsExpr, RenamedPat, RenamedHsCmd, RenamedHsCmdTop ) +import RnHsSyn ( RenamedHsExpr, RenamedPat, RenamedHsCmdTop ) import Outputable import Util ( lengthAtLeast ) diff --git a/ghc/compiler/typecheck/TcBinds.lhs b/ghc/compiler/typecheck/TcBinds.lhs index 446f198b31..a0b0a4ebcf 100644 --- a/ghc/compiler/typecheck/TcBinds.lhs +++ b/ghc/compiler/typecheck/TcBinds.lhs @@ -26,7 +26,7 @@ import TcEnv ( tcExtendLocalValEnv, tcExtendLocalValEnv2, newLocalName ) import TcUnify ( Expected(..), newHole, unifyTauTyLists, checkSigTyVarsWrt, sigCtxt ) import TcSimplify ( tcSimplifyInfer, tcSimplifyInferCheck, tcSimplifyRestricted, tcSimplifyToDicts, tcSimplifyIPs ) -import TcMonoType ( tcHsSigType, UserTypeCtxt(..), TcSigInfo(..), +import TcHsType ( tcHsSigType, UserTypeCtxt(..), TcSigInfo(..), tcTySig, maybeSig, tcSigPolyId, tcSigMonoId, tcAddScopedTyVars ) import TcPat ( tcPat, tcSubPat, tcMonoPatBndr ) @@ -221,12 +221,11 @@ so all the clever stuff is in here. as the Name in the tc_ty_sig \begin{code} -tcBindWithSigs - :: TopLevelFlag - -> RenamedMonoBinds - -> [RenamedSig] -- Used solely to get INLINE, NOINLINE sigs - -> RecFlag - -> TcM (TcMonoBinds, [TcId]) +tcBindWithSigs :: TopLevelFlag + -> RenamedMonoBinds + -> [RenamedSig] + -> RecFlag + -> TcM (TcMonoBinds, [TcId]) tcBindWithSigs top_lvl mbind sigs is_rec = -- TYPECHECK THE SIGNATURES @@ -253,6 +252,8 @@ tcBindWithSigs top_lvl mbind sigs is_rec ) $ -- TYPECHECK THE BINDINGS + traceTc (ptext SLIT("--------------------------------------------------------")) `thenM_` + traceTc (ptext SLIT("Bindings for") <+> ppr (collectMonoBinders mbind)) `thenM_` getLIE (tcMonoBinds mbind tc_ty_sigs is_rec) `thenM` \ ((mbind', bndr_names_w_ids), lie_req) -> let (binder_names, mono_ids) = unzip (bagToList bndr_names_w_ids) @@ -820,7 +821,6 @@ tcSpecSigs (other_sig : sigs) = tcSpecSigs sigs tcSpecSigs [] = returnM EmptyMonoBinds \end{code} - %************************************************************************ %* * \subsection[TcBinds-errors]{Error contexts and messages} diff --git a/ghc/compiler/typecheck/TcClassDcl.lhs b/ghc/compiler/typecheck/TcClassDcl.lhs index 820ed749f5..5e515b6063 100644 --- a/ghc/compiler/typecheck/TcClassDcl.lhs +++ b/ghc/compiler/typecheck/TcClassDcl.lhs @@ -4,63 +4,69 @@ \section[TcClassDcl]{Typechecking class declarations} \begin{code} -module TcClassDcl ( tcClassDecl1, tcClassDecls2, - MethodSpec, tcMethodBind, mkMethodBind, badMethodErr +module TcClassDcl ( tcClassSigs, tcClassDecl2, + getGenericInstances, + MethodSpec, tcMethodBind, mkMethodBind, + tcAddDeclCtxt, badMethodErr ) where #include "HsVersions.h" -import HsSyn ( TyClDecl(..), Sig(..), MonoBinds(..), - HsExpr(..), HsLit(..), Pat(WildPat), +import HsSyn ( TyClDecl(..), Sig(..), MonoBinds(..), HsType(..), + HsExpr(..), HsLit(..), Pat(WildPat), HsTyVarBndr(..), mkSimpleMatch, andMonoBinds, andMonoBindList, - isClassOpSig, isPragSig, - placeHolderType + isPragSig, placeHolderType, mkHsForAllTy ) -import BasicTypes ( RecFlag(..) ) +import BasicTypes ( RecFlag(..), NewOrData(..) ) import RnHsSyn ( RenamedTyClDecl, RenamedSig, RenamedClassOpSig, RenamedMonoBinds, - maybeGenericMatch + maybeGenericMatch, extractHsTyVars ) -import RnEnv ( lookupSysName ) +import RnExpr ( rnExpr ) +import RnEnv ( lookupTopBndrRn, lookupImportedName ) import TcHsSyn ( TcMonoBinds ) import Inst ( Inst, InstOrigin(..), instToId, newDicts, newMethod ) -import TcEnv ( TyThingDetails(..), - tcLookupClass, tcExtendLocalValEnv2, - tcExtendTyVarEnv2, tcExtendTyVarEnv +import TcEnv ( tcLookupClass, tcExtendLocalValEnv2, tcExtendTyVarEnv2, + InstInfo(..), pprInstInfo, simpleInstInfoTyCon, simpleInstInfoTy, + InstBindings(..), newDFunName ) -import TcTyDecls ( tcMkDataCon ) import TcBinds ( tcMonoBinds, tcSpecSigs ) -import TcMonoType ( TcSigInfo(..), tcHsType, tcHsTheta, mkTcSig ) +import TcHsType ( TcSigInfo(..), mkTcSig, tcHsKindedType, tcHsSigType ) import TcSimplify ( tcSimplifyCheck, bindInstsOfLocalFuns ) import TcUnify ( checkSigTyVars, sigCtxt ) -import TcMType ( tcInstTyVars ) +import TcMType ( tcInstTyVars, UserTypeCtxt( GenPatCtxt ) ) import TcType ( Type, TyVarDetails(..), TcType, TcThetaType, TcTyVar, - mkTyVarTys, mkPredTys, mkClassPred, tcSplitSigmaTy, tcSplitFunTys, + mkClassPred, tcSplitSigmaTy, tcSplitFunTys, tcIsTyVarTy, tcSplitTyConApp_maybe, tcSplitForAllTys, tcSplitPhiTy, - getClassPredTys_maybe, mkPhiTy + getClassPredTys_maybe, mkPhiTy, mkTyVarTy ) import TcRnMonad -import Generics ( mkGenericRhs ) +import Generics ( mkGenericRhs, validGenericInstanceType ) import PrelInfo ( nO_METHOD_BINDING_ERROR_ID ) -import Class ( classTyVars, classBigSig, classTyCon, +import Class ( classTyVars, classBigSig, Class, ClassOpItem, DefMeth (..) ) -import TyCon ( tyConGenInfo ) +import TyCon ( TyCon, tyConName, tyConHasGenerics ) import Subst ( substTyWith ) -import MkId ( mkDictSelId, mkDefaultMethodId ) +import MkId ( mkDefaultMethodId, mkDictFunId ) import Id ( Id, idType, idName, mkUserLocal, setInlinePragma ) import Name ( Name, NamedThing(..) ) import NameEnv ( NameEnv, lookupNameEnv, emptyNameEnv, unitNameEnv, plusNameEnv ) -import NameSet ( emptyNameSet, unitNameSet ) -import OccName ( mkClassTyConOcc, mkClassDataConOcc, mkSuperDictSelOcc, reportIfUnused ) +import NameSet ( emptyNameSet, unitNameSet, nameSetToList ) +import OccName ( reportIfUnused, mkDefaultMethodOcc ) +import RdrName ( RdrName, mkDerivedRdrName ) import Outputable import Var ( TyVar ) +import PrelNames ( genericTyConNames ) import CmdLineOpts import UnicodeUtil ( stringToUtf8 ) -import ErrUtils ( dumpIfSet ) -import Util ( count, lengthIs, isSingleton ) -import Maybes ( seqMaybe ) -import Maybe ( isJust ) +import ErrUtils ( dumpIfSet, dumpIfSet_dyn ) +import Util ( count, lengthIs, isSingleton, lengthExceeds ) +import Unique ( Uniquable(..) ) +import ListSetOps ( equivClassesByUniq, minusList ) +import SrcLoc ( SrcLoc ) +import Maybes ( seqMaybe, isJust, mapCatMaybes ) +import List ( partition ) import FastString \end{code} @@ -101,151 +107,70 @@ Death to "ExpandingDicts". %************************************************************************ %* * -\subsection{Type checking} + Type-checking the class op signatures %* * %************************************************************************ \begin{code} +tcClassSigs :: Name -- Name of the class + -> [RenamedClassOpSig] + -> RenamedMonoBinds + -> TcM [TcMethInfo] + +type TcMethInfo = (Name, DefMeth, Type) -- A temporary intermediate, to communicate + -- between tcClassSigs and buildClass +tcClassSigs clas sigs def_methods + = do { dm_env <- checkDefaultBinds clas op_names def_methods + ; mappM (tcClassSig dm_env) op_sigs } + where + op_sigs = [sig | sig@(Sig n _ _) <- sigs] + op_names = [n | sig@(Sig n _ _) <- op_sigs] -tcClassDecl1 :: RenamedTyClDecl -> TcM (Name, TyThingDetails) -tcClassDecl1 (ClassDecl {tcdCtxt = context, tcdName = class_name, - tcdTyVars = tyvar_names, tcdFDs = fundeps, - tcdSigs = class_sigs, tcdMeths = def_methods, - tcdLoc = src_loc}) - = -- LOOK THINGS UP IN THE ENVIRONMENT - tcLookupClass class_name `thenM` \ clas -> - let - tyvars = classTyVars clas - op_sigs = filter isClassOpSig class_sigs - op_names = [n | ClassOpSig n _ _ _ <- op_sigs] - in - tcExtendTyVarEnv tyvars $ - - checkDefaultBinds clas op_names def_methods `thenM` \ mb_dm_env -> - - -- CHECK THE CONTEXT - -- The renamer has already checked that the context mentions - -- only the type variable of the class decl. - -- Context is already kind-checked - tcHsTheta context `thenM` \ sc_theta -> - - -- CHECK THE CLASS SIGNATURES, - mappM (tcClassSig clas tyvars mb_dm_env) op_sigs `thenM` \ sig_stuff -> - - -- MAKE THE CLASS DETAILS - 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 - -- can construct names for the selectors. Thus - -- class (C a, C b) => D a b where ... - -- gives superclass selectors - -- D_sc1, D_sc2 - -- (We used to call them D_C, but now we can have two different - -- superclasses both called C!) - 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] - 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} - -\begin{code} -checkDefaultBinds :: Class -> [Name] -> Maybe RenamedMonoBinds - -> TcM (Maybe (NameEnv Bool)) - -- The returned environment says - -- x not in env => no default method - -- x -> True => generic default method - -- x -> False => polymorphic default method - + +checkDefaultBinds :: Name -> [Name] -> RenamedMonoBinds + -> TcM (NameEnv Bool) -- Check default bindings -- a) must be for a class op for this class -- b) must be all generic or all non-generic - -- and return a mapping from class-op to DefMeth info + -- and return a mapping from class-op to Bool + -- where True <=> it's a generic default method - -- But do all this only for source binds +checkDefaultBinds clas ops EmptyMonoBinds + = returnM emptyNameEnv -checkDefaultBinds clas ops Nothing - = returnM Nothing +checkDefaultBinds clas ops (AndMonoBinds b1 b2) + = do { dm_info1 <- checkDefaultBinds clas ops b1 + ; dm_info2 <- checkDefaultBinds clas ops b2 + ; returnM (dm_info1 `plusNameEnv` dm_info2) } -checkDefaultBinds clas ops (Just mbs) - = go mbs `thenM` \ dm_env -> - returnM (Just dm_env) - where - go EmptyMonoBinds = returnM emptyNameEnv - - go (AndMonoBinds b1 b2) - = go b1 `thenM` \ dm_info1 -> - go b2 `thenM` \ dm_info2 -> - returnM (dm_info1 `plusNameEnv` dm_info2) - - go (FunMonoBind op _ matches loc) - = addSrcLoc loc $ - - -- Check that the op is from this class - checkTc (op `elem` ops) (badMethodErr clas op) `thenM_` +checkDefaultBinds clas ops (FunMonoBind op _ matches loc) + = addSrcLoc loc $ do + { -- Check that the op is from this class + checkTc (op `elem` ops) (badMethodErr clas op) -- Check that all the defns ar generic, or none are - checkTc (all_generic || none_generic) (mixedGenericErr op) `thenM_` + ; checkTc (all_generic || none_generic) (mixedGenericErr op) - returnM (unitNameEnv op all_generic) - where - n_generic = count (isJust . maybeGenericMatch) matches - none_generic = n_generic == 0 - all_generic = matches `lengthIs` n_generic -\end{code} + ; returnM (unitNameEnv op all_generic) + } + where + n_generic = count (isJust . maybeGenericMatch) matches + none_generic = n_generic == 0 + all_generic = matches `lengthIs` n_generic -\begin{code} -tcClassSig :: Class -- ...ditto... - -> [TyVar] -- The class type variable, used for error check only - -> Maybe (NameEnv Bool) -- Info about default methods; - -- Nothing => imported class defn with no method binds +tcClassSig :: NameEnv Bool -- Info about default methods; -> RenamedClassOpSig - -> TcM (Type, -- Type of the method - ClassOpItem) -- Selector Id, default-method Id, True if explicit default binding - --- This warrants an explanation: we need to separate generic --- default methods and default methods later on in the compiler --- so we distinguish them in checkDefaultBinds, and pass this knowledge in the --- Class.DefMeth data structure. - -tcClassSig clas clas_tyvars maybe_dm_env - (ClassOpSig op_name sig_dm op_ty src_loc) - = addSrcLoc src_loc $ - - -- Check the type signature. NB that the envt *already has* - -- bindings for the type variables; see comments in TcTyAndClassDcls. - tcHsType op_ty `thenM` \ local_ty -> - - let - theta = [mkClassPred clas (mkTyVarTys clas_tyvars)] - - -- Build the selector id and default method id - sel_id = mkDictSelId op_name clas - DefMeth dm_name = sig_dm - - dm_info = case maybe_dm_env of - Nothing -> sig_dm - Just dm_env -> mk_src_dm_info dm_env - - mk_src_dm_info dm_env = case lookupNameEnv dm_env op_name of - Nothing -> NoDefMeth - Just True -> GenDefMeth - Just False -> DefMeth dm_name - in - returnM (local_ty, (sel_id, dm_info)) + -> TcM TcMethInfo + +tcClassSig dm_env (Sig op_name op_hs_ty src_loc) + = addSrcLoc src_loc $ do + { op_ty <- tcHsKindedType op_hs_ty -- Class tyvars already in scope + ; let dm = case lookupNameEnv dm_env op_name of + Nothing -> NoDefMeth + Just False -> DefMeth + Just True -> GenDefMeth + ; returnM (op_name, dm, op_ty) } \end{code} @@ -310,25 +235,7 @@ dfun.Foo.List dfoo_list \end{verbatim} -The function @tcClassDecls2@ just arranges to apply @tcClassDecl2@ to -each local class decl. - -\begin{code} -tcClassDecls2 :: [RenamedTyClDecl] -> TcM (TcMonoBinds, [Id]) - -tcClassDecls2 decls - = foldr combine - (returnM (EmptyMonoBinds, [])) - [tcClassDecl2 cls_decl | cls_decl@(ClassDecl {tcdMeths = Just _}) <- decls] - -- The 'Just' picks out source ClassDecls - where - combine tc1 tc2 = tc1 `thenM` \ (binds1, ids1) -> - tc2 `thenM` \ (binds2, ids2) -> - returnM (binds1 `AndMonoBinds` binds2, - ids1 ++ ids2) -\end{code} - -@tcClassDecl2@ generates bindings for polymorphic default methods +@tcClassDecls2@ generates bindings for polymorphic default methods (generic default methods have by now turned into instance declarations) \begin{code} @@ -336,9 +243,8 @@ tcClassDecl2 :: RenamedTyClDecl -- The class declaration -> TcM (TcMonoBinds, [Id]) tcClassDecl2 (ClassDecl {tcdName = class_name, tcdSigs = sigs, - tcdMeths = Just default_binds, tcdLoc = src_loc}) - = -- The 'Just' picks out source ClassDecls - recoverM (returnM (EmptyMonoBinds, [])) $ + tcdMeths = default_binds, tcdLoc = src_loc}) + = recoverM (returnM (EmptyMonoBinds, [])) $ addSrcLoc src_loc $ tcLookupClass class_name `thenM` \ clas -> @@ -354,32 +260,31 @@ tcClassDecl2 (ClassDecl {tcdName = class_name, tcdSigs = sigs, (tyvars, _, _, op_items) = classBigSig clas prags = filter isPragSig sigs tc_dm = tcDefMeth clas tyvars default_binds prags - in - mapAndUnzipM tc_dm op_items `thenM` \ (defm_binds, dm_ids_s) -> - - returnM (andMonoBindList defm_binds, concat dm_ids_s) - -tcDefMeth clas tyvars binds_in prags (_, NoDefMeth) = returnM (EmptyMonoBinds, []) -tcDefMeth clas tyvars binds_in prags (_, GenDefMeth) = returnM (EmptyMonoBinds, []) + dm_sel_ids = [sel_id | (sel_id, DefMeth) <- op_items] -- Generate code for polymorphic default methods only -- (Generic default methods have turned into instance decls by now.) -- This is incompatible with Hugs, which expects a polymorphic -- default method for every class op, regardless of whether or not -- the programmer supplied an explicit default decl for the class. -- (If necessary we can fix that, but we don't have a convenient Id to hand.) - -tcDefMeth clas tyvars binds_in prags op_item@(sel_id, DefMeth dm_name) - = tcInstTyVars ClsTv tyvars `thenM` \ (clas_tyvars, inst_tys, _) -> + in + mapAndUnzipM tc_dm dm_sel_ids `thenM` \ (defm_binds, dm_ids_s) -> + returnM (andMonoBindList defm_binds, concat dm_ids_s) + +tcDefMeth clas tyvars binds_in prags sel_id + = lookupTopBndrRn (mkDefMethRdrName sel_id) `thenM` \ dm_name -> + tcInstTyVars ClsTv tyvars `thenM` \ (clas_tyvars, inst_tys, _) -> let dm_ty = idType sel_id -- Same as dict selector! theta = [mkClassPred clas inst_tys] local_dm_id = mkDefaultMethodId dm_name dm_ty xtve = tyvars `zip` clas_tyvars + origin = ClassDeclOrigin in + mkMethodBind origin clas inst_tys + binds_in (sel_id, DefMeth) `thenM` \ (_, meth_info) -> newDicts origin theta `thenM` \ [this_dict] -> - - mkMethodBind origin clas inst_tys binds_in op_item `thenM` \ (_, meth_info) -> getLIE (tcMethodBind xtve clas_tyvars theta [this_dict] prags meth_info) `thenM` \ (defm_bind, insts_needed) -> @@ -405,11 +310,11 @@ tcDefMeth clas tyvars binds_in prags op_item@(sel_id, DefMeth dm_name) (dict_binds `andMonoBinds` defm_bind) in returnM (full_bind, [local_dm_id]) - where - origin = ClassDeclOrigin + +mkDefMethRdrName :: Id -> RdrName +mkDefMethRdrName sel_id = mkDerivedRdrName (idName sel_id) mkDefaultMethodOcc \end{code} - %************************************************************************ %* * @@ -586,9 +491,11 @@ mkMethId origin clas sel_id inst_tys -- The user didn't supply a method binding, -- so we have to make up a default binding -- The RHS of a default method depends on the default-method info -mkDefMethRhs origin clas inst_tys sel_id loc (DefMeth dm_name) +mkDefMethRhs origin clas inst_tys sel_id loc DefMeth = -- An polymorphic default method - traceRn (text "mkDefMeth" <+> ppr dm_name) `thenM_` + lookupImportedName (mkDefMethRdrName sel_id) `thenM` \ dm_name -> + -- Might not be imported, but will be an OrigName + traceRn (text "mkDefMeth" <+> ppr dm_name) `thenM_` returnM (HsVar dm_name) mkDefMethRhs origin clas inst_tys sel_id loc NoDefMeth @@ -636,11 +543,14 @@ mkDefMethRhs origin clas inst_tys sel_id loc GenDefMeth checkTc (isJust maybe_tycon) (badGenericInstance sel_id (notSimple inst_tys)) `thenM_` - checkTc (isJust (tyConGenInfo tycon)) + checkTc (tyConHasGenerics tycon) (badGenericInstance sel_id (notGeneric tycon)) `thenM_` ioToTcRn (dumpIfSet opt_PprStyle_Debug "Generic RHS" stuff) `thenM_` - returnM rhs + + -- Rename it before returning it + rnExpr rhs `thenM` \ (rn_rhs, _) -> + returnM rn_rhs where rhs = mkGenericRhs sel_id clas_tyvar tycon @@ -672,21 +582,183 @@ find_bind sel_name meth_name (FunMonoBind op_name fix matches loc) find_bind sel_name meth_name (AndMonoBinds b1 b2) = find_bind sel_name meth_name b1 `seqMaybe` find_bind sel_name meth_name b2 find_bind sel_name meth_name other = Nothing -- Default case +\end{code} + + +%************************************************************************ +%* * +\subsection{Extracting generic instance declaration from class declarations} +%* * +%************************************************************************ + +@getGenericInstances@ extracts the generic instance declarations from a class +declaration. For exmaple + + class C a where + op :: a -> a + + op{ x+y } (Inl v) = ... + op{ x+y } (Inr v) = ... + op{ x*y } (v :*: w) = ... + op{ 1 } Unit = ... + +gives rise to the instance declarations + + instance C (x+y) where + op (Inl v) = ... + op (Inr v) = ... + + instance C (x*y) where + op (v :*: w) = ... + + instance C 1 where + op Unit = ... + + +\begin{code} +getGenericInstances :: [RenamedTyClDecl] -> TcM [InstInfo] +getGenericInstances class_decls + = do { gen_inst_infos <- mappM get_generics class_decls + ; let { gen_inst_info = concat gen_inst_infos } + + -- Return right away if there is no generic stuff + ; if null gen_inst_info then returnM [] + else do + + -- Otherwise print it out + { dflags <- getDOpts + ; ioToTcRn (dumpIfSet_dyn dflags Opt_D_dump_deriv "Generic instances" + (vcat (map pprInstInfo gen_inst_info))) + ; returnM gen_inst_info }} + +get_generics decl@(ClassDecl {tcdName = class_name, tcdMeths = def_methods, tcdLoc = loc}) + | null generic_binds + = returnM [] -- The comon case: no generic default methods + + | otherwise -- A source class decl with generic default methods + = recoverM (returnM []) $ + tcAddDeclCtxt decl $ + tcLookupClass class_name `thenM` \ clas -> + + -- Group by type, and + -- make an InstInfo out of each group + let + groups = groupWith andMonoBindList generic_binds + in + mappM (mkGenericInstance clas loc) groups `thenM` \ inst_infos -> + + -- Check that there is only one InstInfo for each type constructor + -- The main way this can fail is if you write + -- f {| a+b |} ... = ... + -- f {| x+y |} ... = ... + -- Then at this point we'll have an InstInfo for each + let + tc_inst_infos :: [(TyCon, InstInfo)] + tc_inst_infos = [(simpleInstInfoTyCon i, i) | i <- inst_infos] + + bad_groups = [group | group <- equivClassesByUniq get_uniq tc_inst_infos, + group `lengthExceeds` 1] + get_uniq (tc,_) = getUnique tc + in + mappM (addErrTc . dupGenericInsts) bad_groups `thenM_` + + -- Check that there is an InstInfo for each generic type constructor + let + missing = genericTyConNames `minusList` [tyConName tc | (tc,_) <- tc_inst_infos] + in + checkTc (null missing) (missingGenericInstances missing) `thenM_` - -- Find the prags for this method, and replace the - -- selector name with the method name -find_prags sel_name meth_name [] = [] -find_prags sel_name meth_name (SpecSig name ty loc : prags) - | name == sel_name = SpecSig meth_name ty loc : find_prags sel_name meth_name prags -find_prags sel_name meth_name (InlineSig sense name phase loc : prags) - | name == sel_name = InlineSig sense meth_name phase loc : find_prags sel_name meth_name prags -find_prags sel_name meth_name (prag:prags) = find_prags sel_name meth_name prags + returnM inst_infos + + where + generic_binds :: [(HsType Name, RenamedMonoBinds)] + generic_binds = getGenericBinds def_methods + + +--------------------------------- +getGenericBinds :: RenamedMonoBinds -> [(HsType Name, RenamedMonoBinds)] + -- Takes a group of method bindings, finds the generic ones, and returns + -- them in finite map indexed by the type parameter in the definition. + +getGenericBinds EmptyMonoBinds = [] +getGenericBinds (AndMonoBinds m1 m2) = getGenericBinds m1 ++ getGenericBinds m2 + +getGenericBinds (FunMonoBind id infixop matches loc) + = groupWith wrap (mapCatMaybes maybeGenericMatch matches) + where + wrap ms = FunMonoBind id infixop ms loc + +groupWith :: ([a] -> b) -> [(HsType Name, a)] -> [(HsType Name, b)] +groupWith op [] = [] +groupWith op ((t,v):prs) = (t, op (v:vs)) : groupWith op rest + where + vs = map snd this + (this,rest) = partition same_t prs + same_t (t',v) = t `eqPatType` t' + +eqPatType :: HsType Name -> HsType Name -> Bool +-- A very simple equality function, only for +-- type patterns in generic function definitions. +eqPatType (HsTyVar v1) (HsTyVar v2) = v1==v2 +eqPatType (HsAppTy s1 t1) (HsAppTy s2 t2) = s1 `eqPatType` s2 && t2 `eqPatType` t2 +eqPatType _ _ = False + +--------------------------------- +mkGenericInstance :: Class -> SrcLoc + -> (HsType Name, RenamedMonoBinds) + -> TcM InstInfo + +mkGenericInstance clas loc (hs_ty, binds) + -- Make a generic instance declaration + -- For example: instance (C a, C b) => C (a+b) where { binds } + + = -- Extract the universally quantified type variables + -- and wrap them as forall'd tyvars, so that kind inference + -- works in the standard way + let + sig_tvs = map UserTyVar (nameSetToList (extractHsTyVars hs_ty)) + hs_forall_ty = mkHsForAllTy (Just sig_tvs) [] hs_ty + in + -- Type-check the instance type, and check its form + tcHsSigType GenPatCtxt hs_forall_ty `thenM` \ forall_inst_ty -> + let + (tyvars, inst_ty) = tcSplitForAllTys forall_inst_ty + in + checkTc (validGenericInstanceType inst_ty) + (badGenericInstanceType binds) `thenM_` + + -- Make the dictionary function. + newDFunName clas [inst_ty] loc `thenM` \ dfun_name -> + let + inst_theta = [mkClassPred clas [mkTyVarTy tv] | tv <- tyvars] + dfun_id = mkDictFunId dfun_name tyvars inst_theta clas [inst_ty] + in + + returnM (InstInfo { iDFunId = dfun_id, iBinds = VanillaInst binds [] }) \end{code} -Contexts and errors -~~~~~~~~~~~~~~~~~~~ +%************************************************************************ +%* * + Error messages +%* * +%************************************************************************ + \begin{code} +tcAddDeclCtxt decl thing_inside + = addSrcLoc (tcdLoc decl) $ + addErrCtxt ctxt $ + thing_inside + where + thing = case decl of + ClassDecl {} -> "class" + TySynonym {} -> "type synonym" + TyData {tcdND = NewType} -> "newtype" + TyData {tcdND = DataType} -> "data type" + + ctxt = hsep [ptext SLIT("In the"), text thing, + ptext SLIT("declaration for"), quotes (ppr (tcdName decl))] + defltMethCtxt clas = ptext SLIT("When checking the default methods for class") <+> quotes (ppr clas) @@ -713,6 +785,21 @@ notGeneric tycon = vcat [ptext SLIT("because the instance type constructor") <+> quotes (ppr tycon) <+> ptext SLIT("was not compiled with -fgenerics")] +badGenericInstanceType binds + = vcat [ptext SLIT("Illegal type pattern in the generic bindings"), + nest 4 (ppr binds)] + +missingGenericInstances missing + = ptext SLIT("Missing type patterns for") <+> pprQuotedList missing + +dupGenericInsts tc_inst_infos + = vcat [ptext SLIT("More than one type pattern for a single generic type constructor:"), + nest 4 (vcat (map ppr_inst_ty tc_inst_infos)), + ptext SLIT("All the type patterns for a generic type constructor must be identical") + ] + where + ppr_inst_ty (tc,inst) = ppr (simpleInstInfoTy inst) + mixedGenericErr op = ptext SLIT("Can't mix generic and non-generic equations for class method") <+> quotes (ppr op) \end{code} diff --git a/ghc/compiler/typecheck/TcDefaults.lhs b/ghc/compiler/typecheck/TcDefaults.lhs index f10745121e..5db1537687 100644 --- a/ghc/compiler/typecheck/TcDefaults.lhs +++ b/ghc/compiler/typecheck/TcDefaults.lhs @@ -11,18 +11,17 @@ module TcDefaults ( tcDefaults ) where import HsSyn ( DefaultDecl(..) ) import Name ( Name ) import TcRnMonad -import TcEnv ( tcLookupGlobal_maybe ) -import TcMonoType ( tcHsType ) +import TcEnv ( tcLookupClass ) +import TcHsType ( tcHsSigType, UserTypeCtxt( DefaultDeclCtxt ) ) import TcSimplify ( tcSimplifyDefault ) import TcType ( Type, mkClassPred, isTauTy ) import PrelNames ( numClassName ) import Outputable -import HscTypes ( TyThing(..) ) \end{code} \begin{code} tcDefaults :: [DefaultDecl Name] - -> TcM [Type] -- Defaulting types to heave + -> TcM (Maybe [Type]) -- Defaulting types to heave -- into Tc monad for later use -- in Disambig. @@ -39,29 +38,19 @@ tcDefaults [] -- defaultDefaultTys tcDefaults [DefaultDecl [] locn] - = returnM [] -- Default declaration specifying no types + = returnM (Just []) -- Default declaration specifying no types tcDefaults [DefaultDecl mono_tys locn] - = tcLookupGlobal_maybe numClassName `thenM` \ maybe_num -> - case maybe_num of - Just (AClass num_class) -> common_case num_class - other -> returnM [] - -- In the Nothing case, Num has not been sucked in, so the - -- defaults will never be used; so simply discard the default decl. - -- This slightly benefits modules that don't use any - -- numeric stuff at all, by avoid the necessity of - -- always sucking in Num - where - common_case num_class - = addSrcLoc locn $ - addErrCtxt defaultDeclCtxt $ - mappM tc_default_ty mono_tys `thenM` \ tau_tys -> + = addSrcLoc locn $ + addErrCtxt defaultDeclCtxt $ + tcLookupClass numClassName `thenM` \ num_class -> + mappM tc_default_ty mono_tys `thenM` \ tau_tys -> - -- Check that all the types are instances of Num - -- We only care about whether it worked or not - tcSimplifyDefault [mkClassPred num_class [ty] | ty <- tau_tys] `thenM_` + -- Check that all the types are instances of Num + -- We only care about whether it worked or not + tcSimplifyDefault [mkClassPred num_class [ty] | ty <- tau_tys] `thenM_` - returnM tau_tys + returnM (Just tau_tys) tcDefaults decls@(DefaultDecl _ loc : _) = addSrcLoc loc $ @@ -69,7 +58,7 @@ tcDefaults decls@(DefaultDecl _ loc : _) = tc_default_ty hs_ty - = tcHsType hs_ty `thenM` \ ty -> + = tcHsSigType DefaultDeclCtxt hs_ty `thenM` \ ty -> checkTc (isTauTy ty) (polyDefErr hs_ty) `thenM_` returnM ty diff --git a/ghc/compiler/typecheck/TcDeriv.lhs b/ghc/compiler/typecheck/TcDeriv.lhs index 60b7b2fcaf..2f63cf7ce7 100644 --- a/ghc/compiler/typecheck/TcDeriv.lhs +++ b/ghc/compiler/typecheck/TcDeriv.lhs @@ -11,25 +11,26 @@ module TcDeriv ( tcDeriving ) where #include "HsVersions.h" import HsSyn ( HsBinds(..), TyClDecl(..), MonoBinds(..), - andMonoBindList, collectMonoBinders ) + andMonoBindList ) import RdrHsSyn ( RdrNameMonoBinds ) import RnHsSyn ( RenamedHsBinds, RenamedTyClDecl, RenamedHsPred ) import CmdLineOpts ( DynFlag(..) ) +import Generics ( mkGenericBinds ) import TcRnMonad -import TcEnv ( tcExtendTempInstEnv, newDFunName, +import TcEnv ( newDFunName, InstInfo(..), pprInstInfo, InstBindings(..), pprInstInfoDetails, tcLookupTyCon, tcExtendTyVarEnv ) import TcGenDeriv -- Deriv stuff -import InstEnv ( simpleDFunClassTyCon ) -import TcMonoType ( tcHsPred ) +import InstEnv ( simpleDFunClassTyCon, extendInstEnv ) +import TcHsType ( tcHsPred ) import TcSimplify ( tcSimplifyDeriv ) import RnBinds ( rnMethodBinds, rnTopMonoBinds ) -import RnEnv ( bindLocalsFV, extendTyVarEnvFVRn ) +import RnEnv ( bindLocalNames ) import TcRnMonad ( thenM, returnM, mapAndUnzipM ) -import HscTypes ( DFunId ) +import HscTypes ( DFunId, FixityEnv, typeEnvTyCons ) import BasicTypes ( NewOrData(..) ) import Class ( className, classArity, classKey, classTyVars, classSCTheta, Class ) @@ -37,18 +38,16 @@ import Subst ( mkTyVarSubst, substTheta ) import ErrUtils ( dumpIfSet_dyn ) import MkId ( mkDictFunId ) import DataCon ( dataConOrigArgTys, isNullaryDataCon, isExistentialDataCon ) -import Maybes ( maybeToBool, catMaybes ) +import Maybes ( catMaybes ) import Name ( Name, getSrcLoc ) import Unique ( Unique, getUnique ) -import NameSet -import RdrName ( RdrName ) import TyCon ( tyConTyVars, tyConDataCons, tyConArity, tyConTheta, isProductTyCon, isDataTyCon, isEnumerationTyCon, isRecursiveTyCon, TyCon ) import TcType ( TcType, ThetaType, mkTyVarTy, mkTyVarTys, mkTyConApp, - getClassPredTys_maybe, + getClassPredTys_maybe, tcTyConAppTyCon, isUnLiftedType, mkClassPred, tyVarsOfTypes, tcSplitFunTys, isTypeKind, tcEqTypes, tcSplitAppTys, mkAppTys, tcSplitDFunTy ) import Var ( TyVar, tyVarKind, idType, varName ) @@ -194,22 +193,21 @@ version. So now all classes are "offending". \begin{code} tcDeriving :: [RenamedTyClDecl] -- All type constructors - -> TcM ([InstInfo], -- The generated "instance decls". - RenamedHsBinds, -- Extra generated bindings - FreeVars) -- These are free in the generated bindings + -> TcM ([InstInfo], -- The generated "instance decls" + RenamedHsBinds) -- Extra generated top-level bindings tcDeriving tycl_decls - = recoverM (returnM ([], EmptyBinds, emptyFVs)) $ + = recoverM (returnM ([], EmptyBinds)) $ getDOpts `thenM` \ dflags -> -- Fish the "deriving"-related information out of the TcEnv -- and make the necessary "equations". makeDerivEqns tycl_decls `thenM` \ (ordinary_eqns, newtype_inst_info) -> - tcExtendTempInstEnv (map iDFunId newtype_inst_info) $ + extendLocalInstEnv (map iDFunId newtype_inst_info) $ -- Add the newtype-derived instances to the inst env -- before tacking the "ordinary" ones - deriveOrdinaryStuff ordinary_eqns `thenM` \ (ordinary_inst_info, binds, fvs) -> + deriveOrdinaryStuff ordinary_eqns `thenM` \ (ordinary_inst_info, binds) -> let inst_info = newtype_inst_info ++ ordinary_inst_info in @@ -217,7 +215,7 @@ tcDeriving tycl_decls ioToTcRn (dumpIfSet_dyn dflags Opt_D_dump_deriv "Derived instances" (ddump_deriving inst_info binds)) `thenM_` - returnM (inst_info, binds, fvs) + returnM (inst_info, binds) where ddump_deriving :: [InstInfo] -> RenamedHsBinds -> SDoc @@ -230,64 +228,35 @@ tcDeriving tycl_decls ----------------------------------------- deriveOrdinaryStuff [] -- Short cut - = returnM ([], EmptyBinds, emptyFVs) + = returnM ([], EmptyBinds) deriveOrdinaryStuff eqns - = -- Take the equation list and solve it, to deliver a list of - -- solutions, a.k.a. the contexts for the instance decls - -- required for the corresponding equations. - solveDerivEqns eqns `thenM` \ new_dfuns -> - - -- Now augment the InstInfos, adding in the rather boring - -- actual-code-to-do-the-methods binds. We may also need to - -- generate extra not-one-inst-decl-specific binds, notably - -- "con2tag" and/or "tag2con" functions. We do these - -- separately. - gen_taggery_Names new_dfuns `thenM` \ nm_alist_etc -> + = do { -- Take the equation list and solve it, to deliver a list of + -- solutions, a.k.a. the contexts for the instance decls + -- required for the corresponding equations. + ; new_dfuns <- solveDerivEqns eqns - let - extra_mbind_list = map gen_tag_n_con_monobind nm_alist_etc - extra_mbinds = andMonoBindList extra_mbind_list - mbinders = collectMonoBinders extra_mbinds - in - mappM gen_bind new_dfuns `thenM` \ rdr_name_inst_infos -> - - traceTc (text "tcDeriv" <+> vcat (map ppr rdr_name_inst_infos)) `thenM_` - getModule `thenM` \ this_mod -> - initRn (InterfaceMode this_mod) ( - -- Rename to get RenamedBinds. - -- The only tricky bit is that the extra_binds must scope - -- over the method bindings for the instances. - bindLocalsFV (ptext (SLIT("deriving"))) mbinders $ \ _ -> - rnTopMonoBinds extra_mbinds [] `thenM` \ (rn_extra_binds, dus) -> - - mapAndUnzipM rn_inst_info rdr_name_inst_infos `thenM` \ (pairs, fvs_s) -> - - let - (rn_inst_infos, aux_binds_s) = unzip pairs - all_binds = rn_extra_binds `ThenBinds` foldr ThenBinds EmptyBinds aux_binds_s - in - returnM ((rn_inst_infos, all_binds), - duUses dus `plusFV` plusFVs fvs_s) - ) `thenM` \ ((rn_inst_infos, rn_extra_binds), fvs) -> - returnM (rn_inst_infos, rn_extra_binds, fvs) + -- Generate the InstInfo for each dfun, + -- plus any auxiliary bindings it needs + ; (inst_infos, aux_binds_s) <- mapAndUnzipM genInst new_dfuns - where - rn_inst_info (dfun, (meth_binds, aux_binds)) - = -- Rename the auxiliary bindings - bindLocalsFV (ptext (SLIT("deriving"))) mbinders $ \ _ -> - rnTopMonoBinds aux_binds [] `thenM` \ (rn_aux_binds, dus) -> - - -- Bring the right type variables into scope - extendTyVarEnvFVRn (map varName tyvars) $ - rnMethodBinds (className cls) [] meth_binds `thenM` \ (rn_meth_binds, fvs) -> - - return ((InstInfo { iDFunId = dfun, iBinds = VanillaInst rn_meth_binds [] }, - rn_aux_binds), - duUses dus `plusFV` fvs) - where - mbinders = collectMonoBinders aux_binds - (tyvars, _, cls, _) = tcSplitDFunTy (idType dfun) + -- Generate any extra not-one-inst-decl-specific binds, + -- notably "con2tag" and/or "tag2con" functions. + ; extra_binds <- genTaggeryBinds new_dfuns + + -- Generate the generic to/from functions from each type declaration + ; tcg_env <- getGblEnv + ; let gen_binds = mkGenericBinds (typeEnvTyCons (tcg_type_env tcg_env)) + + -- Rename these extra bindings + ; (rn_binds, _fvs1) <- rnTopMonoBinds (extra_binds `AndMonoBinds` gen_binds) [] + + ; let all_binds = rn_binds `ThenBinds` + foldr ThenBinds EmptyBinds aux_binds_s + + -- Done + ; traceTc (text "tcDeriv" <+> vcat (map pprInstInfo inst_infos)) + ; returnM (inst_infos, all_binds) } \end{code} @@ -354,8 +323,7 @@ makeDerivEqns tycl_decls = new_dfun_name clas tycon `thenM` \ dfun_name -> returnM (Just (dfun_name, clas, tycon, tyvars, constraints), Nothing) where - tyvars = tyConTyVars tycon - data_cons = tyConDataCons tycon + tyvars = tyConTyVars tycon constraints = extra_constraints ++ ordinary_constraints -- "extra_constraints": see note [Data decl contexts] above extra_constraints = tyConTheta tycon @@ -544,7 +512,6 @@ new_dfun_name clas tycon -- Just a simple wrapper -- The type passed to newDFunName is only used to generate -- a suitable string; hence the empty type arg list - ------------------------------------------------------------------ -- Check side conditions that dis-allow derivability for particular classes -- This is *apart* from the newtype-deriving mechanism @@ -682,7 +649,7 @@ solveDerivEqns orig_eqns checkNoErrs ( -- Extend the inst info from the explicit instance decls -- with the current set of solutions, and simplify each RHS - tcExtendTempInstEnv dfuns $ + extendLocalInstEnv dfuns $ mappM gen_soln orig_eqns ) `thenM` \ new_solns -> if (current_solns == new_solns) then @@ -701,6 +668,15 @@ solveDerivEqns orig_eqns mk_deriv_dfun (dfun_name, clas, tycon, tyvars, _) theta = mkDictFunId dfun_name tyvars theta clas [mkTyConApp tycon (mkTyVarTys tyvars)] + +extendLocalInstEnv :: [DFunId] -> TcM a -> TcM a +-- Add new locall-defined instances; don't bother to check +-- for functional dependency errors -- that'll happen in TcInstDcls +extendLocalInstEnv dfuns thing_inside + = do { env <- getGblEnv + ; let inst_env' = foldl extendInstEnv (tcg_inst_env env) dfuns + env' = env { tcg_inst_env = inst_env' } + ; setGblEnv env' thing_inside } \end{code} %************************************************************************ @@ -766,33 +742,46 @@ the renamer. What a great hack! \end{itemize} \begin{code} --- Generate the method bindings for the required instance --- (paired with DFunId, as we need that when renaming --- the method binds) -gen_bind :: DFunId -> TcM (DFunId, (RdrNameMonoBinds, RdrNameMonoBinds)) -gen_bind dfun +-- Generate the InstInfo for the required instance, +-- plus any auxiliary bindings required +genInst :: DFunId -> TcM (InstInfo, RenamedHsBinds) +genInst dfun = getFixityEnv `thenM` \ fix_env -> let - (clas, tycon) = simpleDFunClassTyCon dfun - gen_binds_fn = assoc "gen_bind:bad derived class" - gen_list (getUnique clas) - - gen_list = [(eqClassKey, no_aux_binds gen_Eq_binds) - ,(ordClassKey, no_aux_binds gen_Ord_binds) - ,(enumClassKey, no_aux_binds gen_Enum_binds) - ,(boundedClassKey, no_aux_binds gen_Bounded_binds) - ,(ixClassKey, no_aux_binds gen_Ix_binds) - ,(showClassKey, no_aux_binds (gen_Show_binds fix_env)) - ,(readClassKey, no_aux_binds (gen_Read_binds fix_env)) - ,(typeableClassKey,no_aux_binds gen_Typeable_binds) - ,(dataClassKey, gen_Data_binds fix_env) - ] - - -- Used for generators that don't need to produce - -- any auxiliary bindings - no_aux_binds f tc = (f tc, EmptyMonoBinds) + (tyvars,_,clas,[ty]) = tcSplitDFunTy (idType dfun) + clas_nm = className clas + tycon = tcTyConAppTyCon ty + (meth_binds, aux_binds) = assoc "gen_bind:bad derived class" + gen_list (getUnique clas) fix_env tycon in - returnM (dfun, gen_binds_fn tycon) + -- Rename the auxiliary bindings (if any) + rnTopMonoBinds aux_binds [] `thenM` \ (rn_aux_binds, _dus) -> + + -- Bring the right type variables into + -- scope, and rename the method binds + bindLocalNames (map varName tyvars) $ + rnMethodBinds clas_nm [] meth_binds `thenM` \ (rn_meth_binds, _fvs) -> + + -- Build the InstInfo + returnM (InstInfo { iDFunId = dfun, iBinds = VanillaInst rn_meth_binds [] }, + rn_aux_binds) + +gen_list :: [(Unique, FixityEnv -> TyCon -> (RdrNameMonoBinds, RdrNameMonoBinds))] +gen_list = [(eqClassKey, no_aux_binds (ignore_fix_env gen_Eq_binds)) + ,(ordClassKey, no_aux_binds (ignore_fix_env gen_Ord_binds)) + ,(enumClassKey, no_aux_binds (ignore_fix_env gen_Enum_binds)) + ,(boundedClassKey, no_aux_binds (ignore_fix_env gen_Bounded_binds)) + ,(ixClassKey, no_aux_binds (ignore_fix_env gen_Ix_binds)) + ,(typeableClassKey,no_aux_binds (ignore_fix_env gen_Typeable_binds)) + ,(showClassKey, no_aux_binds gen_Show_binds) + ,(readClassKey, no_aux_binds gen_Read_binds) + ,(dataClassKey, gen_Data_binds) + ] + + -- no_aux_binds is used for generators that don't + -- need to produce any auxiliary bindings +no_aux_binds f fix_env tc = (f fix_env tc, EmptyMonoBinds) +ignore_fix_env f fix_env tc = f tc \end{code} @@ -829,14 +818,11 @@ We're deriving @Enum@, or @Ix@ (enum type only???) If we have a @tag2con@ function, we also generate a @maxtag@ constant. \begin{code} -gen_taggery_Names :: [DFunId] - -> TcM [(RdrName, -- for an assoc list - TyCon, -- related tycon - TagThingWanted)] - -gen_taggery_Names dfuns - = foldlM do_con2tag [] tycons_of_interest `thenM` \ names_so_far -> - foldlM do_tag2con names_so_far tycons_of_interest +genTaggeryBinds :: [DFunId] -> TcM RdrNameMonoBinds +genTaggeryBinds dfuns + = do { names_so_far <- foldlM do_con2tag [] tycons_of_interest + ; nm_alist_etc <- foldlM do_tag2con names_so_far tycons_of_interest + ; return (andMonoBindList (map gen_tag_n_con_monobind nm_alist_etc)) } where all_CTs = map simpleDFunClassTyCon dfuns all_tycons = map snd all_CTs diff --git a/ghc/compiler/typecheck/TcEnv.lhs b/ghc/compiler/typecheck/TcEnv.lhs index 5360887b78..21fecddae5 100644 --- a/ghc/compiler/typecheck/TcEnv.lhs +++ b/ghc/compiler/typecheck/TcEnv.lhs @@ -1,9 +1,8 @@ \begin{code} module TcEnv( - TyThing(..), TyThingDetails(..), TcTyThing(..), TcId, + TyThing(..), TcTyThing(..), TcId, -- Instance environment, and InstInfo type - tcGetInstEnv, InstInfo(..), pprInstInfo, pprInstInfoDetails, simpleInstInfoTy, simpleInstInfoTyCon, InstBindings(..), @@ -11,21 +10,20 @@ module TcEnv( -- Global environment tcExtendGlobalEnv, tcExtendGlobalValEnv, - tcExtendGlobalTypeEnv, - tcLookupTyCon, tcLookupClass, tcLookupDataCon, - tcLookupGlobal_maybe, tcLookupGlobal, tcLookupGlobalId, + tcLookupGlobal, + tcLookupGlobalId, tcLookupTyCon, tcLookupClass, tcLookupDataCon, + getInGlobalScope, -- Local environment - tcExtendKindEnv, + tcExtendTyVarKindEnv, tcExtendTyVarEnv, tcExtendTyVarEnv2, tcExtendLocalValEnv, tcExtendLocalValEnv2, - tcLookup, tcLookupLocalIds, tcLookup_maybe, - tcLookupId, + tcLookup, tcLookupLocalIds, + tcLookupId, tcLookupTyVar, lclEnvElts, getInLocalScope, findGlobals, - -- Instance environment - tcExtendLocalInstEnv, tcExtendInstEnv, tcExtendTempInstEnv, tcWithTempInstEnv, + tcExtendRecEnv, -- For knot-tying -- Rules tcExtendRules, @@ -41,298 +39,121 @@ module TcEnv( checkProcLevel, -- New Ids - newLocalName, newDFunName, - - -- Misc - isLocalThing + newLocalName, newDFunName ) where #include "HsVersions.h" import RnHsSyn ( RenamedMonoBinds, RenamedSig ) -import HsSyn ( RuleDecl(..), ifaceRuleDeclName ) +import HsSyn ( RuleDecl(..), , HsTyVarBndr(..) ) +import TcIface ( tcImportDecl ) import TcRnMonad import TcMType ( zonkTcType, zonkTcTyVar, zonkTcTyVarsAndFV ) -import TcType ( Type, ThetaType, TcKind, TcTyVar, TcTyVarSet, +import TcType ( Type, TcTyVar, TcTyVarSet, tyVarsOfType, tyVarsOfTypes, tcSplitDFunTy, mkGenTyConApp, getDFunTyKey, tcTyConAppTyCon, tyVarBindingInfo, tidyOpenType, tidyOpenTyVar ) import qualified Type ( getTyVar_maybe ) -import Rules ( extendRuleBase ) import Id ( idName, isLocalId ) -import Var ( TyVar, Id, idType ) +import Var ( TyVar, Id, mkTyVar, idType ) import VarSet import VarEnv -import CoreSyn ( IdCoreRule ) import DataCon ( DataCon ) -import TyCon ( TyCon, DataConDetails ) -import Class ( Class, ClassOpItem ) +import TyCon ( TyCon ) +import Class ( Class ) import Name ( Name, NamedThing(..), getSrcLoc, mkInternalName, nameIsLocalOrFrom ) import NameEnv import OccName ( mkDFunOcc, occNameString ) -import HscTypes ( DFunId, TypeEnv, extendTypeEnvList, lookupType, - TyThing(..), ExternalPackageState(..) ) -import Rules ( RuleBase ) -import BasicTypes ( EP ) -import Module ( Module ) -import InstEnv ( InstEnv, extendInstEnv ) +import HscTypes ( DFunId, extendTypeEnvList, lookupType, + TyThing(..), tyThingId, tyThingTyCon, tyThingClass, tyThingDataCon, + ExternalPackageState(..) ) + import SrcLoc ( SrcLoc ) import Outputable import Maybe ( isJust ) -import List ( partition ) \end{code} %************************************************************************ %* * - Arrow notation proc levels +%* tcLookupGlobal * %* * %************************************************************************ \begin{code} -checkProcLevel :: TcId -> ProcLevel -> TcM () -checkProcLevel id id_lvl - = do { banned <- getBannedProcLevels - ; checkTc (not (id_lvl `elem` banned)) - (procLevelErr id id_lvl) } - -procLevelErr id id_lvl - = hang (ptext SLIT("Command-bound variable") <+> quotes (ppr id) <+> ptext SLIT("is not in scope here")) - 4 (ptext SLIT("Reason: it is used in the left argument of (-<)")) +tcLookupGlobal :: Name -> TcM TyThing +-- c.f. IfaceEnvEnv.tcIfaceGlobal +tcLookupGlobal name + = do { env <- getGblEnv + ; if nameIsLocalOrFrom (tcg_mod env) name + + then -- It's defined in this module + case lookupNameEnv (tcg_type_env env) name of + Just thing -> return thing + Nothing -> notFound "tcLookupGlobal" name + + else do -- It's imported + { eps <- getEps + ; hpt <- getHpt + ; case lookupType hpt (eps_PTE eps) name of + Just thing -> return thing + Nothing -> do { traceIf (text "tcLookupGlobal" <+> ppr name) + ; initIfaceTcRn (tcImportDecl name) } + }} \end{code} - - -%************************************************************************ -%* * - Meta level -%* * -%************************************************************************ \begin{code} -instance Outputable ThStage where - ppr Comp = text "Comp" - ppr (Brack l _ _) = text "Brack" <+> int l - ppr (Splice l) = text "Splice" <+> int l - - -thLevel :: ThStage -> ThLevel -thLevel Comp = topLevel -thLevel (Splice l) = l -thLevel (Brack l _ _) = l - - -checkWellStaged :: SDoc -- What the stage check is for - -> ThLevel -- Binding level - -> ThStage -- Use stage - -> TcM () -- Fail if badly staged, adding an error -checkWellStaged pp_thing bind_lvl use_stage - | bind_lvl <= use_lvl -- OK! - = returnM () - - | bind_lvl == topLevel -- GHC restriction on top level splices - = failWithTc $ - sep [ptext SLIT("GHC stage restriction:") <+> pp_thing, - nest 2 (ptext SLIT("is used in a top-level splice, and must be imported, not defined locally"))] - - | otherwise -- Badly staged - = failWithTc $ - ptext SLIT("Stage error:") <+> pp_thing <+> - hsep [ptext SLIT("is bound at stage") <+> ppr bind_lvl, - ptext SLIT("but used at stage") <+> ppr use_lvl] - where - use_lvl = thLevel use_stage - - -topIdLvl :: Id -> ThLevel --- Globals may either be imported, or may be from an earlier "chunk" --- (separated by declaration splices) of this module. The former --- *can* be used inside a top-level splice, but the latter cannot. --- Hence we give the former impLevel, but the latter topLevel --- E.g. this is bad: --- x = [| foo |] --- $( f x ) --- By the time we are prcessing the $(f x), the binding for "x" --- will be in the global env, not the local one. -topIdLvl id | isLocalId id = topLevel - | otherwise = impLevel - --- Indicates the legal transitions on bracket( [| |] ). -bracketOK :: ThStage -> Maybe ThLevel -bracketOK (Brack _ _ _) = Nothing -- Bracket illegal inside a bracket -bracketOK stage = (Just (thLevel stage + 1)) - --- Indicates the legal transitions on splice($). -spliceOK :: ThStage -> Maybe ThLevel -spliceOK (Splice _) = Nothing -- Splice illegal inside splice -spliceOK stage = Just (thLevel stage - 1) - -tcMetaTy :: Name -> TcM Type --- Given the name of a Template Haskell data type, --- return the type --- E.g. given the name "Expr" return the type "Expr" -tcMetaTy tc_name - = tcLookupTyCon tc_name `thenM` \ t -> - returnM (mkGenTyConApp t []) - -- Use mkGenTyConApp because it might be a synonym -\end{code} - - -%************************************************************************ -%* * -\subsection{TyThingDetails} -%* * -%************************************************************************ +tcLookupGlobalId :: Name -> TcM Id +-- Never used for Haskell-source DataCons, hence no ADataCon case +tcLookupGlobalId name + = tcLookupGlobal name `thenM` \ thing -> + return (tyThingId thing) -This data type is used to help tie the knot - when type checking type and class declarations +tcLookupDataCon :: Name -> TcM DataCon +tcLookupDataCon con_name + = tcLookupGlobal con_name `thenM` \ thing -> + return (tyThingDataCon thing) -\begin{code} -data TyThingDetails = SynTyDetails Type - | DataTyDetails ThetaType (DataConDetails DataCon) [Id] (Maybe (EP Id)) - | ClassDetails ThetaType [Id] [ClassOpItem] DataCon Name - -- The Name is the Name of the implicit TyCon for the class - | ForeignTyDetails -- Nothing yet +tcLookupClass :: Name -> TcM Class +tcLookupClass name + = tcLookupGlobal name `thenM` \ thing -> + return (tyThingClass thing) + +tcLookupTyCon :: Name -> TcM TyCon +tcLookupTyCon name + = tcLookupGlobal name `thenM` \ thing -> + return (tyThingTyCon thing) \end{code} - %************************************************************************ %* * -\subsection{Making new Ids} + Extending the global environment %* * %************************************************************************ -Constructing new Ids - -\begin{code} -newLocalName :: Name -> TcM Name -newLocalName name -- Make a clone - = newUnique `thenM` \ uniq -> - returnM (mkInternalName uniq (getOccName name) (getSrcLoc name)) -\end{code} - -Make a name for the dict fun for an instance decl. It's a *local* -name for the moment. The CoreTidy pass will externalise it. Even in ---make and ghci stuff, we rebuild the instance environment each time, -so the dfun id is internal to begin with, and external when compiling -other modules - -\begin{code} -newDFunName :: Class -> [Type] -> SrcLoc -> TcM Name -newDFunName clas (ty:_) loc - = newUnique `thenM` \ uniq -> - returnM (mkInternalName uniq (mkDFunOcc dfun_string) loc) - where - -- Any string that is somewhat unique will do - dfun_string = occNameString (getOccName clas) ++ occNameString (getDFunTyKey ty) - -newDFunName clas [] loc = pprPanic "newDFunName" (ppr clas <+> ppr loc) -\end{code} - -\begin{code} -isLocalThing :: NamedThing a => Module -> a -> Bool -isLocalThing mod thing = nameIsLocalOrFrom mod (getName thing) -\end{code} - -%************************************************************************ -%* * -\subsection{The global environment} -%* * -%************************************************************************ \begin{code} tcExtendGlobalEnv :: [TyThing] -> TcM r -> TcM r - -- Given a mixture of Ids, TyCons, Classes, perhaps from the - -- module being compiled, perhaps from a package module, - -- extend the global environment, and update the EPS + -- Given a mixture of Ids, TyCons, Classes, all from the + -- module being compiled, extend the global environment tcExtendGlobalEnv things thing_inside - = do { eps <- getEps - ; hpt <- getHpt - ; env <- getGblEnv - ; let mod = tcg_mod env - (lcl_things, pkg_things) = partition (isLocalThing mod) things - ge' = extendTypeEnvList (tcg_type_env env) lcl_things - eps' = eps { eps_PTE = extendTypeEnvList (eps_PTE eps) pkg_things } - ; setEps eps' + = do { env <- getGblEnv + ; let ge' = extendTypeEnvList (tcg_type_env env) things ; setGblEnv (env {tcg_type_env = ge'}) thing_inside } tcExtendGlobalValEnv :: [Id] -> TcM a -> TcM a -- Same deal as tcExtendGlobalEnv, but for Ids tcExtendGlobalValEnv ids thing_inside = tcExtendGlobalEnv [AnId id | id <- ids] thing_inside - -tcExtendGlobalTypeEnv :: TypeEnv -> TcM r -> TcM r - -- Top-level things of the interactive context - -- No need to extend the package env -tcExtendGlobalTypeEnv extra_env thing_inside - = do { env <- getGblEnv - ; let ge' = tcg_type_env env `plusNameEnv` extra_env - ; setGblEnv (env {tcg_type_env = ge'}) thing_inside } -\end{code} - - -\begin{code} -tcLookupGlobal_maybe :: Name -> TcRn m (Maybe TyThing) --- This is a rather heavily-used function, so I've inlined a few things (e.g. getEps) --- Notice that for imported things we read the current version from the EPS --- mutable variable. This is important in situations like --- ...$(e1)...$(e2)... --- where the code that e1 expands to might import some defns that --- also turn out to be needed by the code that e2 expands to. -tcLookupGlobal_maybe name - = do { env <- getGblEnv - ; if nameIsLocalOrFrom (tcg_mod env) name then - -- Defined in this module - return (lookupNameEnv (tcg_type_env env) name) - else - do { env <- getTopEnv - ; eps <- readMutVar (top_eps env) - ; return (lookupType (top_hpt env) (eps_PTE eps) name) }} \end{code} A variety of global lookups, when we know what we are looking for. \begin{code} -tcLookupGlobal :: Name -> TcM TyThing -tcLookupGlobal name - = tcLookupGlobal_maybe name `thenM` \ maybe_thing -> - case maybe_thing of - Just thing -> returnM thing - other -> notFound "tcLookupGlobal" name - -tcLookupGlobalId :: Name -> TcM Id --- Never used for Haskell-source DataCons, hence no ADataCon case -tcLookupGlobalId name - = tcLookupGlobal_maybe name `thenM` \ maybe_thing -> - case maybe_thing of - Just (AnId id) -> returnM id - other -> notFound "tcLookupGlobal (id)" name - -tcLookupDataCon :: Name -> TcM DataCon -tcLookupDataCon con_name - = 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 - = tcLookupGlobal_maybe name `thenM` \ maybe_clas -> - case maybe_clas of - Just (AClass clas) -> returnM clas - other -> notFound "tcLookupClass" name - -tcLookupTyCon :: Name -> TcM TyCon -tcLookupTyCon name - = tcLookupGlobal_maybe name `thenM` \ maybe_tc -> - case maybe_tc of - Just (ATyCon tc) -> returnM tc - other -> notFound "tcLookupTyCon" name - - -getInGlobalScope :: TcRn m (Name -> Bool) +getInGlobalScope :: TcM (Name -> Bool) -- Get all things in the global environment; used for deciding what -- rules to suck in. Anything defined in this module (nameIsLocalOrFrom) -- is certainly in the envt, so we don't bother to look. @@ -345,6 +166,20 @@ getInGlobalScope \end{code} +\begin{code} +tcExtendRecEnv :: [(Name,TyThing)] -- Global bindings + -> [(Name,TcTyThing)] -- Local bindings + -> TcM r -> TcM r +-- Extend both local and global environments for the type/class knot tying game +tcExtendRecEnv gbl_stuff lcl_stuff thing_inside + = do { (gbl_env, lcl_env) <- getEnvs + ; let { ge' = extendNameEnvList (tcg_type_env gbl_env) gbl_stuff + ; le' = extendNameEnvList (tcl_env lcl_env) lcl_stuff } + ; setEnvs (gbl_env {tcg_type_env = ge'}, lcl_env {tcl_env = le'}) + thing_inside } +\end{code} + + %************************************************************************ %* * \subsection{The local environment} @@ -352,23 +187,20 @@ getInGlobalScope %************************************************************************ \begin{code} -tcLookup_maybe :: Name -> TcM (Maybe TcTyThing) -tcLookup_maybe name - = getLclEnv `thenM` \ local_env -> - case lookupNameEnv (tcl_env local_env) name of - Just thing -> returnM (Just thing) - Nothing -> tcLookupGlobal_maybe name `thenM` \ mb_res -> - returnM (case mb_res of - Just thing -> Just (AGlobal thing) - Nothing -> Nothing) - tcLookup :: Name -> TcM TcTyThing tcLookup name - = tcLookup_maybe name `thenM` \ maybe_thing -> - case maybe_thing of + = getLclEnv `thenM` \ local_env -> + case lookupNameEnv (tcl_env local_env) name of Just thing -> returnM thing - other -> notFound "tcLookup" name - -- Extract the IdInfo from an IfaceSig imported from an interface file + Nothing -> tcLookupGlobal name `thenM` \ thing -> + returnM (AGlobal thing) + +tcLookupTyVar :: Name -> TcM Id +tcLookupTyVar name + = tcLookup name `thenM` \ thing -> + case thing of + ATyVar tv -> returnM tv + other -> pprPanic "tcLookupTyVar" (ppr name) tcLookupId :: Name -> TcM Id -- Used when we aren't interested in the binding level @@ -405,14 +237,16 @@ getInLocalScope = getLclEnv `thenM` \ env -> \end{code} \begin{code} -tcExtendKindEnv :: [(Name,TcKind)] -> TcM r -> TcM r -tcExtendKindEnv pairs thing_inside +tcExtendTyVarKindEnv :: [HsTyVarBndr Name] -> TcM r -> TcM r +-- The tyvars are all kinded +tcExtendTyVarKindEnv tvs thing_inside = updLclEnv upd thing_inside where upd lcl_env = lcl_env { tcl_env = extend (tcl_env lcl_env) } - extend env = extendNameEnvList env [(n, AThing k) | (n,k) <- pairs] + extend env = extendNameEnvList env [(n, ATyVar (mkTyVar n k)) + | KindedTyVar n k <- tvs] -- No need to extend global tyvars for kind checking - + tcExtendTyVarEnv :: [TyVar] -> TcM r -> TcM r tcExtendTyVarEnv tvs thing_inside = tc_extend_tv_env [(getName tv, ATyVar tv) | tv <- tvs] tvs thing_inside @@ -431,7 +265,7 @@ tc_extend_tv_env binds tyvars thing_inside in -- It's important to add the in-scope tyvars to the global tyvar set -- as well. Consider - -- f (x::r) = let g y = y::r in ... + -- f (_::r) = let g y = y::r in ... -- Here, g mustn't be generalised. This is also important during -- class and instance decls, when we mustn't generalise the class tyvars -- when typechecking the methods. @@ -477,8 +311,8 @@ tcExtendLocalValEnv2 names_w_ids thing_inside -- We must be careful to pass it a zonked type variable, too. findGlobals :: TcTyVarSet - -> TidyEnv - -> TcM (TidyEnv, [SDoc]) + -> TidyEnv + -> TcM (TidyEnv, [SDoc]) findGlobals tvs tidy_env = getLclEnv `thenM` \ lcl_env -> @@ -515,8 +349,9 @@ find_thing ignore_it tidy_env (ATyVar tv) (tidy_env2, tidy_ty) = tidyOpenType tidy_env1 tv_ty msg = sep [ppr tv1 <+> eq_stuff, nest 2 bound_at] - eq_stuff | Just tv' <- Type.getTyVar_maybe tv_ty, tv == tv' = empty - | otherwise = equals <+> ppr tv_ty + eq_stuff | Just tv' <- Type.getTyVar_maybe tv_ty, + tv == tv' = empty + | otherwise = equals <+> ppr tidy_ty -- It's ok to use Type.getTyVar_maybe because ty is zonked by now bound_at = tyVarBindingInfo tv @@ -554,132 +389,149 @@ tcGetGlobalTyVars %************************************************************************ %* * -\subsection{The instance environment} +\subsection{Rules} %* * %************************************************************************ -The TcGblEnv holds a mutable variable containing the current full, instance environment. -The ExtendInstEnv functions extend this environment by side effect, in case we are -sucking in new instance declarations deep in the body of a TH splice, which are needed -in another TH splice. The tcg_insts field of the TcGblEnv contains just the dfuns -from this module - \begin{code} -tcGetInstEnv :: TcM InstEnv -tcGetInstEnv = do { env <- getGblEnv; readMutVar (tcg_inst_env env) } - -tcExtendInstEnv :: [DFunId] -> TcM a -> TcM a - -- Add instances from local or imported - -- instances, and refresh the instance-env cache -tcExtendInstEnv dfuns thing_inside - = do { dflags <- getDOpts - ; eps <- getEps - ; env <- getGblEnv - ; let ie_var = tcg_inst_env env - ; inst_env <- readMutVar ie_var +tcExtendRules :: [RuleDecl Id] -> TcM a -> TcM a + -- Just pop the new rules into the EPS and envt resp + -- All the rules come from an interface file, not soruce + -- Nevertheless, some may be for this module, if we read + -- its interface instead of its source code +tcExtendRules lcl_rules thing_inside + = do { env <- getGblEnv ; let - -- Extend the total inst-env with the new dfuns - (inst_env', errs) = extendInstEnv dflags inst_env dfuns - - -- Sort the ones from this module from the others - (lcl_dfuns, pkg_dfuns) = partition (isLocalThing mod) dfuns - mod = tcg_mod env - - -- And add the pieces to the right places - (eps_inst_env', _) = extendInstEnv dflags (eps_inst_env eps) pkg_dfuns - eps' = eps { eps_inst_env = eps_inst_env' } - - env' = env { tcg_insts = lcl_dfuns ++ tcg_insts env } - - ; traceDFuns dfuns - ; addErrs errs - ; writeMutVar ie_var inst_env' - ; setEps eps' + env' = env { tcg_rules = lcl_rules ++ tcg_rules env } ; setGblEnv env' thing_inside } +\end{code} -tcExtendLocalInstEnv :: [InstInfo] -> TcM a -> TcM a - -- Special case for local instance decls -tcExtendLocalInstEnv infos thing_inside - = do { dflags <- getDOpts - ; env <- getGblEnv - ; let ie_var = tcg_inst_env env - ; inst_env <- readMutVar ie_var - ; let - dfuns = map iDFunId infos - (inst_env', errs) = extendInstEnv dflags inst_env dfuns - env' = env { tcg_insts = dfuns ++ tcg_insts env } - ; traceDFuns dfuns - ; addErrs errs - ; writeMutVar ie_var inst_env' - ; setGblEnv env' thing_inside } -tcExtendTempInstEnv :: [DFunId] -> TcM a -> TcM a - -- Extend the instance envt, but with *no* permanent - -- effect on mutable variables; also ignore errors - -- Used during 'deriving' stuff -tcExtendTempInstEnv dfuns thing_inside - = do { dflags <- getDOpts - ; env <- getGblEnv - ; let ie_var = tcg_inst_env env - ; inst_env <- readMutVar ie_var - ; let (inst_env', errs) = extendInstEnv dflags inst_env dfuns - -- Ignore the errors about duplicate instances. - -- We don't want repeated error messages - -- They'll appear later, when we do the top-level extendInstEnvs - ; writeMutVar ie_var inst_env' - ; result <- thing_inside - ; writeMutVar ie_var inst_env -- Restore! - ; return result } - -tcWithTempInstEnv :: TcM a -> TcM a --- Run thing_inside, discarding any effects on the instance environment -tcWithTempInstEnv thing_inside - = do { env <- getGblEnv - ; let ie_var = tcg_inst_env env - ; old_ie <- readMutVar ie_var - ; result <- thing_inside - ; writeMutVar ie_var old_ie -- Restore - ; return result } - -traceDFuns dfuns - = traceTc (text "Adding instances:" <+> vcat (map pp dfuns)) +%************************************************************************ +%* * + Arrow notation proc levels +%* * +%************************************************************************ + +\begin{code} +checkProcLevel :: TcId -> ProcLevel -> TcM () +checkProcLevel id id_lvl + = do { banned <- getBannedProcLevels + ; checkTc (not (id_lvl `elem` banned)) + (procLevelErr id id_lvl) } + +procLevelErr id id_lvl + = hang (ptext SLIT("Command-bound variable") <+> quotes (ppr id) <+> ptext SLIT("is not in scope here")) + 4 (ptext SLIT("Reason: it is used in the left argument of (-<)")) +\end{code} + + +%************************************************************************ +%* * + Meta level +%* * +%************************************************************************ + +\begin{code} +instance Outputable ThStage where + ppr Comp = text "Comp" + ppr (Brack l _ _) = text "Brack" <+> int l + ppr (Splice l) = text "Splice" <+> int l + + +thLevel :: ThStage -> ThLevel +thLevel Comp = topLevel +thLevel (Splice l) = l +thLevel (Brack l _ _) = l + + +checkWellStaged :: SDoc -- What the stage check is for + -> ThLevel -- Binding level + -> ThStage -- Use stage + -> TcM () -- Fail if badly staged, adding an error +checkWellStaged pp_thing bind_lvl use_stage + | bind_lvl <= use_lvl -- OK! + = returnM () + + | bind_lvl == topLevel -- GHC restriction on top level splices + = failWithTc $ + sep [ptext SLIT("GHC stage restriction:") <+> pp_thing, + nest 2 (ptext SLIT("is used in a top-level splice, and must be imported, not defined locally"))] + + | otherwise -- Badly staged + = failWithTc $ + ptext SLIT("Stage error:") <+> pp_thing <+> + hsep [ptext SLIT("is bound at stage") <+> ppr bind_lvl, + ptext SLIT("but used at stage") <+> ppr use_lvl] where - pp dfun = ppr dfun <+> dcolon <+> ppr (idType dfun) + use_lvl = thLevel use_stage + + +topIdLvl :: Id -> ThLevel +-- Globals may either be imported, or may be from an earlier "chunk" +-- (separated by declaration splices) of this module. The former +-- *can* be used inside a top-level splice, but the latter cannot. +-- Hence we give the former impLevel, but the latter topLevel +-- E.g. this is bad: +-- x = [| foo |] +-- $( f x ) +-- By the time we are prcessing the $(f x), the binding for "x" +-- will be in the global env, not the local one. +topIdLvl id | isLocalId id = topLevel + | otherwise = impLevel + +-- Indicates the legal transitions on bracket( [| |] ). +bracketOK :: ThStage -> Maybe ThLevel +bracketOK (Brack _ _ _) = Nothing -- Bracket illegal inside a bracket +bracketOK stage = (Just (thLevel stage + 1)) + +-- Indicates the legal transitions on splice($). +spliceOK :: ThStage -> Maybe ThLevel +spliceOK (Splice _) = Nothing -- Splice illegal inside splice +spliceOK stage = Just (thLevel stage - 1) + +tcMetaTy :: Name -> TcM Type +-- Given the name of a Template Haskell data type, +-- return the type +-- E.g. given the name "Expr" return the type "Expr" +tcMetaTy tc_name + = tcLookupTyCon tc_name `thenM` \ t -> + returnM (mkGenTyConApp t []) + -- Use mkGenTyConApp because it might be a synonym \end{code} %************************************************************************ %* * -\subsection{Rules} +\subsection{Making new Ids} %* * %************************************************************************ -\begin{code} -tcExtendRules :: [RuleDecl Id] -> TcM a -> TcM a - -- Just pop the new rules into the EPS and envt resp - -- All the rules come from an interface file, not soruce - -- Nevertheless, some may be for this module, if we read - -- its interface instead of its source code -tcExtendRules rules thing_inside - = do { eps <- getEps - ; env <- getGblEnv - ; let - (lcl_rules, pkg_rules) = partition is_local_rule rules - is_local_rule = isLocalThing mod . ifaceRuleDeclName - mod = tcg_mod env +Constructing new Ids - core_rules = [(id,rule) | IfaceRuleOut id rule <- pkg_rules] - eps' = eps { eps_rule_base = addIfaceRules (eps_rule_base eps) core_rules } - -- All the rules from an interface are of the IfaceRuleOut form +\begin{code} +newLocalName :: Name -> TcM Name +newLocalName name -- Make a clone + = newUnique `thenM` \ uniq -> + returnM (mkInternalName uniq (getOccName name) (getSrcLoc name)) +\end{code} - env' = env { tcg_rules = lcl_rules ++ tcg_rules env } +Make a name for the dict fun for an instance decl. It's a *local* +name for the moment. The CoreTidy pass will externalise it. Even in +--make and ghci stuff, we rebuild the instance environment each time, +so the dfun id is internal to begin with, and external when compiling +other modules - ; setEps eps' - ; setGblEnv env' thing_inside } +\begin{code} +newDFunName :: Class -> [Type] -> SrcLoc -> TcM Name +newDFunName clas (ty:_) loc + = newUnique `thenM` \ uniq -> + returnM (mkInternalName uniq (mkDFunOcc dfun_string) loc) + where + -- Any string that is somewhat unique will do + dfun_string = occNameString (getOccName clas) ++ occNameString (getDFunTyKey ty) -addIfaceRules :: RuleBase -> [IdCoreRule] -> RuleBase -addIfaceRules rule_base rules - = foldl extendRuleBase rule_base rules +newDFunName clas [] loc = pprPanic "newDFunName" (ppr clas <+> ppr loc) \end{code} @@ -741,8 +593,6 @@ simpleInstInfoTyCon inst = tcTyConAppTyCon (simpleInstInfoTy inst) %************************************************************************ \begin{code} -badCon con_id = quotes (ppr con_id) <+> ptext SLIT("is not a data constructor") - notFound wheRe name = failWithTc (text wheRe <> colon <+> quotes (ppr name) <+> ptext SLIT("is not in scope")) \end{code} diff --git a/ghc/compiler/typecheck/TcExpr.lhs b/ghc/compiler/typecheck/TcExpr.lhs index 096efb4353..562510e847 100644 --- a/ghc/compiler/typecheck/TcExpr.lhs +++ b/ghc/compiler/typecheck/TcExpr.lhs @@ -11,16 +11,16 @@ module TcExpr ( tcCheckSigma, tcCheckRho, tcInferRho, tcMonoExpr ) where #ifdef GHCI /* Only if bootstrapped */ import {-# SOURCE #-} TcSplice( tcSpliceExpr, tcBracket ) import HsSyn ( HsReify(..), ReifyFlavour(..) ) +import Id ( Id ) import TcType ( isTauTy ) -import TcEnv ( bracketOK, tcMetaTy, checkWellStaged ) -import Name ( isExternalName ) +import TcEnv ( tcMetaTy, checkWellStaged ) import qualified DsMeta #endif import HsSyn ( HsExpr(..), HsLit(..), ArithSeqInfo(..), recBindFields, HsMatchContext(..) ) import RnHsSyn ( RenamedHsExpr, RenamedRecordBinds ) -import TcHsSyn ( TcExpr, TcRecordBinds, hsLitType, mkHsDictApp, mkHsTyApp, mkHsLet, (<$>) ) +import TcHsSyn ( TcExpr, TcRecordBinds, hsLitType, mkHsDictApp, mkHsTyApp, (<$>) ) import TcRnMonad import TcUnify ( Expected(..), newHole, zapExpectedType, zapExpectedTo, tcSubExp, tcGen, unifyFunTy, zapToListTy, zapToPArrTy, zapToTupleTy ) @@ -31,25 +31,24 @@ import Inst ( InstOrigin(..), instToId, tcInstCall, tcInstDataCon ) import TcBinds ( tcBindsAndThen ) -import TcEnv ( tcLookupClass, tcLookupGlobal_maybe, tcLookup, - tcLookupTyCon, tcLookupDataCon, tcLookupId, checkProcLevel +import TcEnv ( tcLookup, tcLookupGlobalId, + tcLookupDataCon, tcLookupId, checkProcLevel ) import TcArrows ( tcProc ) import TcMatches ( tcMatchesCase, tcMatchLambda, tcDoStmts, tcThingWithSig, TcMatchCtxt(..) ) -import TcMonoType ( tcHsSigType, UserTypeCtxt(..) ) +import TcHsType ( tcHsSigType, UserTypeCtxt(..) ) import TcPat ( badFieldCon ) -import TcMType ( tcInstTyVars, tcInstType, newTyVarTy, newTyVarTys, zonkTcType ) +import TcMType ( tcInstTyVars, tcInstType, newTyVarTy, zonkTcType ) import TcType ( TcType, TcSigmaType, TcRhoType, TyVarDetails(VanillaTv), tcSplitFunTys, tcSplitTyConApp, mkTyVarTys, isSigmaTy, mkFunTy, mkFunTys, - mkTyConApp, mkClassPred, - tyVarsOfTypes, isLinearPred, + mkTyConApp, tyVarsOfTypes, isLinearPred, liftedTypeKind, openTypeKind, tcSplitSigmaTy, tidyOpenType ) import FieldLabel ( FieldLabel, fieldLabelName, fieldLabelType, fieldLabelTyCon ) -import Id ( Id, idType, recordSelectorFieldLabel, isRecordSelector ) -import DataCon ( DataCon, dataConFieldLabels, dataConSig, dataConStrictMarks, dataConWrapId ) +import Id ( idType, recordSelectorFieldLabel, isRecordSelector ) +import DataCon ( DataCon, dataConFieldLabels, dataConStrictMarks, dataConWrapId ) import Name ( Name ) import TyCon ( TyCon, tyConTyVars, tyConTheta, isAlgTyCon, tyConDataCons ) import Subst ( mkTopTyVarSubst, substTheta, substTy ) @@ -57,8 +56,7 @@ import VarSet ( emptyVarSet, elemVarSet ) import TysWiredIn ( boolTy ) import PrelNames ( enumFromName, enumFromThenName, enumFromToName, enumFromThenToName, - enumFromToPName, enumFromThenToPName, - ioTyConName + enumFromToPName, enumFromThenToPName ) import ListSetOps ( minusList ) import CmdLineOpts @@ -388,14 +386,14 @@ tcMonoExpr expr@(RecordUpd record_expr rbinds) res_ty let field_names = recBindFields rbinds in - mappM tcLookupGlobal_maybe field_names `thenM` \ maybe_sel_ids -> + mappM tcLookupGlobalId field_names `thenM` \ sel_ids -> + -- The renamer has already checked that they + -- are all in scope let bad_guys = [ addErrTc (notSelector field_name) - | (field_name, maybe_sel_id) <- field_names `zip` maybe_sel_ids, - not (is_selector maybe_sel_id) + | (field_name, sel_id) <- field_names `zip` sel_ids, + not (isRecordSelector sel_id) -- Excludes class ops ] - is_selector (Just (AnId sel_id)) = isRecordSelector sel_id -- Excludes class ops - is_selector other = False in checkM (null bad_guys) (sequenceM bad_guys `thenM_` failM) `thenM_` @@ -403,7 +401,7 @@ tcMonoExpr expr@(RecordUpd record_expr rbinds) res_ty -- Figure out the tycon and data cons from the first field name let -- It's OK to use the non-tc splitters here (for a selector) - (Just (AnId sel_id) : _) = maybe_sel_ids + sel_id : _ = sel_ids field_lbl = recordSelectorFieldLabel sel_id -- We've failed already if tycon = fieldLabelTyCon field_lbl -- it's not a field label data_cons = tyConDataCons tycon @@ -731,15 +729,15 @@ tcId name -- Look up the Id and instantiate its type = -- First check whether it's a DataCon -- Reason: we must not forget to chuck in the -- constraints from their "silly context" - tcLookup name `thenM` \ maybe_thing -> - case maybe_thing of { + tcLookup name `thenM` \ thing -> + case thing of { AGlobal (ADataCon data_con) -> inst_data_con data_con ; AGlobal (AnId id) -> loop (HsVar id) (idType id) -- A global cannot possibly be ill-staged -- nor does it need the 'lifting' treatment ; ATcId id th_level proc_level -> tc_local_id id th_level proc_level - ; other -> pprPanic "tcId" (ppr name) + ; other -> pprPanic "tcId" (ppr name $$ ppr thing) } where @@ -931,10 +929,7 @@ checkMissingFields data_con rbinds field_labels field_strs - field_strs = dropList ex_theta (dataConStrictMarks data_con) - -- The 'drop' is because dataConStrictMarks - -- includes the existential dictionaries - (_, _, _, ex_theta, _, _) = dataConSig data_con + field_strs = dataConStrictMarks data_con \end{code} %************************************************************************ @@ -1019,11 +1014,6 @@ appCtxt fun args where the_app = foldl HsApp fun args -- Used in error messages -lurkingRank2Err fun fun_ty - = hang (hsep [ptext SLIT("Illegal use of"), quotes (ppr fun)]) - 4 (vcat [ptext SLIT("It is applied to too few arguments"), - ptext SLIT("so that the result type has for-alls in it:") <+> ppr fun_ty]) - badFieldsUpd rbinds = hang (ptext SLIT("No constructor has all these fields:")) 4 (pprQuotedList (recBindFields rbinds)) @@ -1050,10 +1040,6 @@ missingFields con fields = ptext SLIT("Fields of") <+> quotes (ppr con) <+> ptext SLIT("not initialised:") <+> pprWithCommas ppr fields -polySpliceErr :: Id -> SDoc -polySpliceErr id - = ptext SLIT("Can't splice the polymorphic local variable") <+> quotes (ppr id) - wrongArgsCtxt too_many_or_few fun args = hang (ptext SLIT("Probable cause:") <+> quotes (ppr fun) <+> ptext SLIT("is applied to") <+> text too_many_or_few @@ -1061,4 +1047,10 @@ wrongArgsCtxt too_many_or_few fun args 4 (parens (ppr the_app)) where the_app = foldl HsApp fun args -- Used in error messages + +#ifdef GHCI +polySpliceErr :: Id -> SDoc +polySpliceErr id + = ptext SLIT("Can't splice the polymorphic local variable") <+> quotes (ppr id) +#endif \end{code} diff --git a/ghc/compiler/typecheck/TcForeign.lhs b/ghc/compiler/typecheck/TcForeign.lhs index 04e6ce4709..3b880c0c61 100644 --- a/ghc/compiler/typecheck/TcForeign.lhs +++ b/ghc/compiler/typecheck/TcForeign.lhs @@ -27,7 +27,7 @@ import HsSyn ( ForeignDecl(..), HsExpr(..), import RnHsSyn ( RenamedForeignDecl ) import TcRnMonad -import TcMonoType ( tcHsSigType, UserTypeCtxt(..) ) +import TcHsType ( tcHsSigType, UserTypeCtxt(..) ) import TcHsSyn ( TcMonoBinds, TypecheckedForeignDecl, TcForeignDecl ) import TcExpr ( tcCheckSigma ) @@ -225,7 +225,8 @@ tcFExport fo@(ForeignExport nm hs_ty spec isDeprec src_loc) = newUnique `thenM` \ uniq -> getModule `thenM` \ mod -> let - gnm = mkExternalName uniq mod (mkForeignExportOcc (getOccName nm)) src_loc + gnm = mkExternalName uniq mod (mkForeignExportOcc (getOccName nm)) + Nothing src_loc id = setIdLocalExported (mkLocalId gnm sig_ty) bind = VarMonoBind id rhs in @@ -291,9 +292,6 @@ checkDotnet _ = Just (text "requires C code generation (-fvia-C)") checkDotnet other = Just (text "requires .NET support (-filx or win32)") #endif -checkC HscC = Nothing -checkC other = Just (text "requires C code generation (-fvia-C)") - checkCOrAsm HscC = Nothing checkCOrAsm HscAsm = Nothing checkCOrAsm other @@ -305,12 +303,6 @@ checkCOrAsmOrInterp HscInterpreted = Nothing checkCOrAsmOrInterp other = Just (text "requires interpreted, C or native code generation") -checkCOrAsmOrDotNet HscC = Nothing -checkCOrAsmOrDotNet HscAsm = Nothing -checkCOrAsmOrDotNet HscILX = Nothing -checkCOrAsmOrDotNet other - = Just (text "requires C, native or .NET ILX code generation") - checkCOrAsmOrDotNetOrInterp HscC = Nothing checkCOrAsmOrDotNetOrInterp HscAsm = Nothing checkCOrAsmOrDotNetOrInterp HscILX = Nothing diff --git a/ghc/compiler/typecheck/TcGenDeriv.lhs b/ghc/compiler/typecheck/TcGenDeriv.lhs index 210710ed30..9cef7b8211 100644 --- a/ghc/compiler/typecheck/TcGenDeriv.lhs +++ b/ghc/compiler/typecheck/TcGenDeriv.lhs @@ -28,42 +28,38 @@ module TcGenDeriv ( #include "HsVersions.h" -import HsSyn ( Pat(..), HsConDetails(..), HsExpr(..), MonoBinds(..), - Match(..), GRHSs(..), Stmt(..), HsLit(..), - HsBinds(..), HsType(..), HsStmtContext(..), - unguardedRHS, mkSimpleMatch, mkMonoBind, andMonoBindList, placeHolderType - ) -import RdrName ( RdrName, mkUnqual, mkRdrUnqual, nameRdrName, getRdrName ) +import HsSyn +import RdrName ( RdrName, mkVarUnqual, mkRdrUnqual, getRdrName, mkDerivedRdrName ) import RdrHsSyn ( mkHsOpApp, RdrNameMonoBinds, RdrNameHsExpr, RdrNamePat, mkHsDo ) -import BasicTypes ( RecFlag(..), Fixity(..), FixityDirection(..) - , maxPrecedence - , Boxity(..) - ) +import BasicTypes ( RecFlag(..), Fixity(..), maxPrecedence, Boxity(..) ) import FieldLabel ( fieldLabelName ) import DataCon ( isNullaryDataCon, dataConTag, dataConOrigArgTys, dataConSourceArity, fIRST_TAG, - DataCon, + DataCon, dataConName, dataConFieldLabels ) import Name ( getOccString, getOccName, getSrcLoc, occNameString, - occNameUserString, varName, + occNameUserString, Name, NamedThing(..), isDataSymOcc, isSymOcc ) import HscTypes ( FixityEnv, lookupFixity ) -import PrelNames -- Lots of Names -import PrimOp -- Lots of Names +import PrelInfo +import PrelNames +import TysWiredIn +import MkId ( eRROR_ID ) +import PrimOp ( PrimOp(..) ) import SrcLoc ( generatedSrcLoc, SrcLoc ) import TyCon ( TyCon, isNewTyCon, tyConDataCons, isEnumerationTyCon, - maybeTyConSingleCon, tyConFamilySize, tyConTyVars + maybeTyConSingleCon, tyConFamilySize, tyConTyVars, tyConName ) import TcType ( isUnLiftedType, tcEqType, Type ) -import TysPrim ( charPrimTy, intPrimTy, wordPrimTy, addrPrimTy, floatPrimTy, doublePrimTy ) -import TysWiredIn ( charDataCon, intDataCon, floatDataCon, doubleDataCon, wordDataCon ) +import TysPrim ( charPrimTy, intPrimTy, wordPrimTy, addrPrimTy, floatPrimTy, doublePrimTy, + intPrimTyCon ) +import TysWiredIn ( charDataCon, intDataCon, floatDataCon, doubleDataCon ) import Util ( zipWithEqual, isSingleton, zipWith3Equal, nOfThem, zipEqual ) -import Panic ( panic, assertPanic ) -import Char ( ord, isAlpha ) +import Char ( isAlpha ) import Constants import List ( partition, intersperse ) import Outputable @@ -423,10 +419,10 @@ gen_Enum_binds tycon = mk_easy_FunMonoBind tycon_loc succ_RDR [a_Pat] [] $ untag_Expr tycon [(a_RDR, ah_RDR)] $ HsIf (mkHsApps eq_RDR [HsVar (maxtag_RDR tycon), - mkHsVarApps mkInt_RDR [ah_RDR]]) + mkHsVarApps intDataCon_RDR [ah_RDR]]) (illegal_Expr "succ" occ_nm "tried to take `succ' of last tag in enumeration") (HsApp (HsVar (tag2con_RDR tycon)) - (mkHsApps plus_RDR [mkHsVarApps mkInt_RDR [ah_RDR], + (mkHsApps plus_RDR [mkHsVarApps intDataCon_RDR [ah_RDR], mkHsIntLit 1])) tycon_loc @@ -434,10 +430,10 @@ gen_Enum_binds tycon = mk_easy_FunMonoBind tycon_loc pred_RDR [a_Pat] [] $ untag_Expr tycon [(a_RDR, ah_RDR)] $ HsIf (mkHsApps eq_RDR [mkHsIntLit 0, - mkHsVarApps mkInt_RDR [ah_RDR]]) + mkHsVarApps intDataCon_RDR [ah_RDR]]) (illegal_Expr "pred" occ_nm "tried to take `pred' of first tag in enumeration") (HsApp (HsVar (tag2con_RDR tycon)) - (mkHsApps plus_RDR [mkHsVarApps mkInt_RDR [ah_RDR], + (mkHsApps plus_RDR [mkHsVarApps intDataCon_RDR [ah_RDR], HsLit (HsInt (-1))])) tycon_loc @@ -456,7 +452,7 @@ gen_Enum_binds tycon mkHsApps map_RDR [HsVar (tag2con_RDR tycon), HsPar (enum_from_to_Expr - (mkHsVarApps mkInt_RDR [ah_RDR]) + (mkHsVarApps intDataCon_RDR [ah_RDR]) (HsVar (maxtag_RDR tycon)))] enum_from_then @@ -464,10 +460,10 @@ gen_Enum_binds tycon untag_Expr tycon [(a_RDR, ah_RDR), (b_RDR, bh_RDR)] $ HsApp (mkHsVarApps map_RDR [tag2con_RDR tycon]) $ HsPar (enum_from_then_to_Expr - (mkHsVarApps mkInt_RDR [ah_RDR]) - (mkHsVarApps mkInt_RDR [bh_RDR]) - (HsIf (mkHsApps gt_RDR [mkHsVarApps mkInt_RDR [ah_RDR], - mkHsVarApps mkInt_RDR [bh_RDR]]) + (mkHsVarApps intDataCon_RDR [ah_RDR]) + (mkHsVarApps intDataCon_RDR [bh_RDR]) + (HsIf (mkHsApps gt_RDR [mkHsVarApps intDataCon_RDR [ah_RDR], + mkHsVarApps intDataCon_RDR [bh_RDR]]) (mkHsIntLit 0) (HsVar (maxtag_RDR tycon)) tycon_loc)) @@ -475,7 +471,7 @@ gen_Enum_binds tycon from_enum = mk_easy_FunMonoBind tycon_loc fromEnum_RDR [a_Pat] [] $ untag_Expr tycon [(a_RDR, ah_RDR)] $ - (mkHsVarApps mkInt_RDR [ah_RDR]) + (mkHsVarApps intDataCon_RDR [ah_RDR]) \end{code} %************************************************************************ @@ -593,8 +589,8 @@ gen_Ix_binds tycon untag_Expr tycon [(b_RDR, bh_RDR)] $ HsApp (mkHsVarApps map_RDR [tag2con_RDR tycon]) $ HsPar (enum_from_to_Expr - (mkHsVarApps mkInt_RDR [ah_RDR]) - (mkHsVarApps mkInt_RDR [bh_RDR])) + (mkHsVarApps intDataCon_RDR [ah_RDR]) + (mkHsVarApps intDataCon_RDR [bh_RDR])) enum_index = mk_easy_FunMonoBind tycon_loc index_RDR @@ -604,11 +600,11 @@ gen_Ix_binds tycon untag_Expr tycon [(a_RDR, ah_RDR)] ( untag_Expr tycon [(d_RDR, dh_RDR)] ( let - rhs = mkHsVarApps mkInt_RDR [c_RDR] + rhs = mkHsVarApps intDataCon_RDR [c_RDR] in HsCase (genOpApp (HsVar dh_RDR) minusInt_RDR (HsVar ah_RDR)) - [mk_triv_Match (VarPat c_RDR) rhs] + [mkSimpleHsAlt (VarPat c_RDR) rhs] tycon_loc )) ) {-else-} ( @@ -808,9 +804,7 @@ gen_Read_binds get_fixity tycon field_stmts = zipWithEqual "lbl_stmts" read_field labels as_needed con_arity = dataConSourceArity data_con - nullary_con = con_arity == 0 labels = dataConFieldLabels data_con - lab_fields = length labels dc_nm = getName data_con is_infix = isDataSymOcc (getOccName dc_nm) as_needed = take con_arity as_RDRs @@ -985,13 +979,6 @@ getPrecedence :: FixityEnv -> Name -> Integer getPrecedence get_fixity nm = case lookupFixity get_fixity nm of Fixity x _ -> fromIntegral x - -isLRAssoc :: FixityEnv -> Name -> (Bool, Bool) -isLRAssoc get_fixity nm = - case lookupFixity get_fixity nm of - Fixity _ InfixN -> (False, False) - Fixity _ InfixR -> (False, True) - Fixity _ InfixL -> (True, False) \end{code} @@ -1072,6 +1059,7 @@ gen_Data_binds fix_env tycon datatype_bind `AndMonoBinds` andMonoBindList (map mk_con_bind data_cons)) where tycon_loc = getSrcLoc tycon + tycon_name = tyConName tycon data_cons = tyConDataCons tycon ------------ gfoldl @@ -1088,27 +1076,29 @@ gen_Data_binds fix_env tycon fromCon_bind = mk_FunMonoBind tycon_loc fromConstr_RDR [([c_Pat], from_con_rhs)] from_con_rhs = HsCase (HsVar conIndex_RDR `HsApp` c_Expr) (map from_con_alt data_cons) tycon_loc - from_con_alt dc = mk_triv_Match (ConPatIn mkInt_RDR (PrefixCon [LitPat (HsIntPrim (toInteger (dataConTag dc)))])) + from_con_alt dc = mkSimpleHsAlt (ConPatIn intDataCon_RDR (PrefixCon [LitPat (HsIntPrim (toInteger (dataConTag dc)))])) (mkHsVarApps (getRdrName dc) (replicate (dataConSourceArity dc) undefined_RDR)) ------------ toConstr toCon_bind = mk_FunMonoBind tycon_loc toConstr_RDR (map to_con_eqn data_cons) - to_con_eqn dc = ([mkWildConPat dc], HsVar (mkConstrName dc)) + to_con_eqn dc = ([mkWildConPat dc], HsVar (mk_constr_name dc)) ------------ dataTypeOf dataTypeOf_bind = mk_easy_FunMonoBind tycon_loc dataTypeOf_RDR [wildPat] [] (HsVar data_type_name) ------------ $dT - data_type_name = mkDataTypeName tycon + data_type_name = mkDerivedRdrName tycon_name mkDataTOcc datatype_bind = mkVarMonoBind tycon_loc data_type_name (HsVar mkDataType_RDR `HsApp` ExplicitList placeHolderType constrs) - constrs = [HsVar (mkConstrName con) | con <- data_cons] + constrs = [HsVar (mk_constr_name con) | con <- data_cons] + ------------ $cT1 etc - mk_con_bind dc = mkVarMonoBind tycon_loc (mkConstrName dc) + mk_constr_name con = mkDerivedRdrName (dataConName con) mkDataCOcc + mk_con_bind dc = mkVarMonoBind tycon_loc (mk_constr_name dc) (mkHsApps mkConstr_RDR (constr_args dc)) constr_args dc = [mkHsIntLit (toInteger (dataConTag dc)), -- Tag HsLit (mkHsString (occNameUserString dc_occ)), -- String name @@ -1128,17 +1118,6 @@ mkDataType_RDR = varQual_RDR gENERICS_Name FSLIT("mkDataType") conIndex_RDR = varQual_RDR gENERICS_Name FSLIT("conIndex") prefix_RDR = dataQual_RDR gENERICS_Name FSLIT("Prefix") infix_RDR = dataQual_RDR gENERICS_Name FSLIT("Infix") - -mkDataTypeName :: TyCon -> RdrName -- $tT -mkDataTypeName tc = mkRdrUnqual (mkDataTOcc (getOccName tc)) - -mkConstrName :: DataCon -> RdrName -- $cT1 -mkConstrName con = mkRdrUnqual (mkDataCOcc (getOccName con)) - - -apN :: Int -> (a -> a) -> a -> a -apN 0 k z = z -apN n k z = apN (n-1) k (k z) \end{code} %************************************************************************ @@ -1178,20 +1157,22 @@ gen_tag_n_con_monobind (rdr_name, tycon, GenCon2Tag) where loc = getSrcLoc tycon + tvs = map (mkRdrUnqual . getOccName) (tyConTyVars tycon) + -- We can't use gerRdrName because that makes an Exact RdrName + -- and we can't put them in the LocalRdrEnv + -- Give a signature to the bound variable, so -- that the case expression generated by getTag is -- monomorphic. In the push-enter model we get better code. get_tag_rhs = ExprWithTySig - (HsLam (mk_match loc [VarPat a_RDR] - (HsApp getTag_Expr a_Expr) - EmptyBinds)) - (HsForAllTy Nothing [] con2tag_ty) - -- Nothing => implicit quantification + (HsLam (mkSimpleHsAlt (VarPat a_RDR) + (HsApp (HsVar getTag_RDR) a_Expr))) + (HsForAllTy (Just (map UserTyVar tvs)) [] con2tag_ty) con2tag_ty = foldl HsAppTy (HsTyVar (getRdrName tycon)) - [HsTyVar (getRdrName tv) | tv <- tyConTyVars tycon] + (map HsTyVar tvs) `HsFunTy` - HsTyVar (getRdrName intPrimTyConName) + HsTyVar (getRdrName intPrimTyCon) lots_of_constructors = tyConFamilySize tycon > mAX_FAMILY_SIZE_FOR_VEC_RETURNS @@ -1201,13 +1182,13 @@ gen_tag_n_con_monobind (rdr_name, tycon, GenCon2Tag) gen_tag_n_con_monobind (rdr_name, tycon, GenTag2Con) = mk_FunMonoBind (getSrcLoc tycon) rdr_name - [([mkConPat mkInt_RDR [a_RDR]], - ExprWithTySig (HsApp tagToEnum_Expr a_Expr) + [([mkConPat intDataCon_RDR [a_RDR]], + ExprWithTySig (HsApp (HsVar tagToEnum_RDR) a_Expr) (HsTyVar (getRdrName tycon)))] gen_tag_n_con_monobind (rdr_name, tycon, GenMaxTag) = mkVarMonoBind (getSrcLoc tycon) rdr_name - (HsApp (HsVar mkInt_RDR) (HsLit (HsIntPrim max_tag))) + (HsApp (HsVar intDataCon_RDR) (HsLit (HsIntPrim max_tag))) where max_tag = case (tyConDataCons tycon) of data_cons -> toInteger ((length data_cons) - fIRST_TAG) @@ -1251,8 +1232,6 @@ mk_easy_Match loc pats binds expr -- "recursive" MonoBinds, and it is its job to sort things out -- from there. -mk_triv_Match pat expr = mkSimpleMatch [pat] expr placeHolderType generatedSrcLoc - mk_FunMonoBind :: SrcLoc -> RdrName -> [([RdrNamePat], RdrNameHsExpr)] -> RdrNameMonoBinds @@ -1269,19 +1248,12 @@ mk_match loc pats expr binds where paren p@(VarPat _) = p paren other_p = ParPat other_p -\end{code} -\begin{code} -mkHsApps f xs = foldl HsApp (HsVar f) xs -mkHsVarApps f xs = foldl HsApp (HsVar f) (map HsVar xs) - -mkHsIntLit n = HsLit (HsInt n) -mkHsString s = HsString (mkFastString s) -mkHsChar c = HsChar (ord c) +mkWildConPat :: DataCon -> Pat RdrName +mkWildConPat con = ConPatIn (getRdrName con) (PrefixCon (nOfThem (dataConSourceArity con) wildPat)) -mkConPat con vars = ConPatIn con (PrefixCon (map VarPat vars)) -mkNullaryConPat con = ConPatIn con (PrefixCon []) -mkWildConPat con = ConPatIn (getRdrName con) (PrefixCon (nOfThem (dataConSourceArity con) wildPat)) +wildPat :: Pat id +wildPat = WildPat placeHolderType -- Pre-typechecking \end{code} ToDo: Better SrcLocs. @@ -1305,9 +1277,9 @@ compare_gen_Case (HsVar eq_tag) a b | eq_tag == eqTag_RDR = HsApp (HsApp (HsVar compare_RDR) a) b -- Simple case compare_gen_Case eq a b -- General case = HsCase (HsPar (HsApp (HsApp (HsVar compare_RDR) a) b)) {-of-} - [mk_triv_Match (mkNullaryConPat ltTag_RDR) ltTag_Expr, - mk_triv_Match (mkNullaryConPat eqTag_RDR) eq, - mk_triv_Match (mkNullaryConPat gtTag_RDR) gtTag_Expr] + [mkSimpleHsAlt (mkNullaryConPat ltTag_RDR) ltTag_Expr, + mkSimpleHsAlt (mkNullaryConPat eqTag_RDR) eq, + mkSimpleHsAlt (mkNullaryConPat gtTag_RDR) gtTag_Expr] generatedSrcLoc careful_compare_Case tycon ty eq a b @@ -1319,8 +1291,8 @@ careful_compare_Case tycon ty eq a b (HsIf (genOpApp a relevant_lt_op b) ltTag_Expr gtTag_Expr generatedSrcLoc) generatedSrcLoc where - relevant_eq_op = assoc_ty_id "Ord" tycon eq_op_tbl ty - relevant_lt_op = assoc_ty_id "Ord" tycon lt_op_tbl ty + relevant_eq_op = primOpRdrName (assoc_ty_id "Ord" tycon eq_op_tbl ty) + relevant_lt_op = primOpRdrName (assoc_ty_id "Ord" tycon lt_op_tbl ty) box_if_necy :: String -- The class involved @@ -1346,28 +1318,30 @@ assoc_ty_id cls_str tycon tbl ty where res = [id | (ty',id) <- tbl, ty `tcEqType` ty'] +eq_op_tbl :: [(Type, PrimOp)] eq_op_tbl = - [(charPrimTy, eqChar_RDR) - ,(intPrimTy, eqInt_RDR) - ,(wordPrimTy, eqWord_RDR) - ,(addrPrimTy, eqAddr_RDR) - ,(floatPrimTy, eqFloat_RDR) - ,(doublePrimTy, eqDouble_RDR) + [(charPrimTy, CharEqOp) + ,(intPrimTy, IntEqOp) + ,(wordPrimTy, WordEqOp) + ,(addrPrimTy, AddrEqOp) + ,(floatPrimTy, FloatEqOp) + ,(doublePrimTy, DoubleEqOp) ] +lt_op_tbl :: [(Type, PrimOp)] lt_op_tbl = - [(charPrimTy, ltChar_RDR) - ,(intPrimTy, ltInt_RDR) - ,(wordPrimTy, ltWord_RDR) - ,(addrPrimTy, ltAddr_RDR) - ,(floatPrimTy, ltFloat_RDR) - ,(doublePrimTy, ltDouble_RDR) + [(charPrimTy, CharLtOp) + ,(intPrimTy, IntLtOp) + ,(wordPrimTy, WordLtOp) + ,(addrPrimTy, AddrLtOp) + ,(floatPrimTy, FloatLtOp) + ,(doublePrimTy, DoubleLtOp) ] box_con_tbl = [(charPrimTy, getRdrName charDataCon) ,(intPrimTy, getRdrName intDataCon) - ,(wordPrimTy, getRdrName wordDataCon) + ,(wordPrimTy, wordDataCon_RDR) ,(addrPrimTy, addrDataCon_RDR) ,(floatPrimTy, getRdrName floatDataCon) ,(doublePrimTy, getRdrName doubleDataCon) @@ -1375,10 +1349,8 @@ box_con_tbl = ----------------------------------------------------------------------- -and_Expr, append_Expr :: RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr - -and_Expr a b = genOpApp a and_RDR b -append_Expr a b = genOpApp a append_RDR b +and_Expr :: RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr +and_Expr a b = genOpApp a and_RDR b ----------------------------------------------------------------------- @@ -1389,16 +1361,15 @@ eq_Expr tycon ty a b = genOpApp a eq_op b | not (isUnLiftedType ty) = eq_RDR | otherwise = -- we have to do something special for primitive things... - assoc_ty_id "Eq" tycon eq_op_tbl ty - + primOpRdrName (assoc_ty_id "Eq" tycon eq_op_tbl ty) \end{code} \begin{code} untag_Expr :: TyCon -> [(RdrName, RdrName)] -> RdrNameHsExpr -> RdrNameHsExpr untag_Expr tycon [] expr = expr untag_Expr tycon ((untag_this, put_tag_here) : more) expr - = HsCase (HsPar (HsApp (con2tag_Expr tycon) (HsVar untag_this))) {-of-} - [mk_triv_Match (VarPat put_tag_here) (untag_Expr tycon more expr)] + = HsCase (HsPar (mkHsVarApps (con2tag_RDR tycon) [untag_this])) {-of-} + [mkSimpleHsAlt (VarPat put_tag_here) (untag_Expr tycon more expr)] generatedSrcLoc cmp_tags_Expr :: RdrName -- Comparison op @@ -1465,82 +1436,68 @@ parenify e = HsPar e -- genOpApp wraps brackets round the operator application, so that the -- renamer won't subsequently try to re-associate it. --- For some reason the renamer doesn't reassociate it right, and I can't --- be bothered to find out why just now. - -genOpApp e1 op e2 = mkHsOpApp e1 op e2 +genOpApp e1 op e2 = HsPar (mkHsOpApp e1 op e2) \end{code} \begin{code} -varUnqual n = mkUnqual OccName.varName n - -zz_a_RDR = varUnqual FSLIT("_a") -a_RDR = varUnqual FSLIT("a") -b_RDR = varUnqual FSLIT("b") -c_RDR = varUnqual FSLIT("c") -d_RDR = varUnqual FSLIT("d") -e_RDR = varUnqual FSLIT("e") -k_RDR = varUnqual FSLIT("k") -z_RDR = varUnqual FSLIT("z") :: RdrName -ah_RDR = varUnqual FSLIT("a#") -bh_RDR = varUnqual FSLIT("b#") -ch_RDR = varUnqual FSLIT("c#") -dh_RDR = varUnqual FSLIT("d#") -cmp_eq_RDR = varUnqual FSLIT("cmp_eq") -rangeSize_RDR = varUnqual FSLIT("rangeSize") - -as_RDRs = [ varUnqual (mkFastString ("a"++show i)) | i <- [(1::Int) .. ] ] -bs_RDRs = [ varUnqual (mkFastString ("b"++show i)) | i <- [(1::Int) .. ] ] -cs_RDRs = [ varUnqual (mkFastString ("c"++show i)) | i <- [(1::Int) .. ] ] - -zz_a_Expr = HsVar zz_a_RDR +a_RDR = mkVarUnqual FSLIT("a") +b_RDR = mkVarUnqual FSLIT("b") +c_RDR = mkVarUnqual FSLIT("c") +d_RDR = mkVarUnqual FSLIT("d") +k_RDR = mkVarUnqual FSLIT("k") +z_RDR = mkVarUnqual FSLIT("z") +ah_RDR = mkVarUnqual FSLIT("a#") +bh_RDR = mkVarUnqual FSLIT("b#") +ch_RDR = mkVarUnqual FSLIT("c#") +dh_RDR = mkVarUnqual FSLIT("d#") +cmp_eq_RDR = mkVarUnqual FSLIT("cmp_eq") +rangeSize_RDR = mkVarUnqual FSLIT("rangeSize") + +as_RDRs = [ mkVarUnqual (mkFastString ("a"++show i)) | i <- [(1::Int) .. ] ] +bs_RDRs = [ mkVarUnqual (mkFastString ("b"++show i)) | i <- [(1::Int) .. ] ] +cs_RDRs = [ mkVarUnqual (mkFastString ("c"++show i)) | i <- [(1::Int) .. ] ] + a_Expr = HsVar a_RDR b_Expr = HsVar b_RDR c_Expr = HsVar c_RDR -d_Expr = HsVar d_RDR -z_Expr = HsVar z_RDR ltTag_Expr = HsVar ltTag_RDR eqTag_Expr = HsVar eqTag_RDR gtTag_Expr = HsVar gtTag_RDR false_Expr = HsVar false_RDR true_Expr = HsVar true_RDR -getTag_Expr = HsVar getTag_RDR -tagToEnum_Expr = HsVar tagToEnum_RDR -con2tag_Expr tycon = HsVar (con2tag_RDR tycon) - -wildPat = WildPat placeHolderType -zz_a_Pat = VarPat zz_a_RDR a_Pat = VarPat a_RDR b_Pat = VarPat b_RDR c_Pat = VarPat c_RDR d_Pat = VarPat d_RDR con2tag_RDR, tag2con_RDR, maxtag_RDR :: TyCon -> RdrName +-- Generates Orig RdrNames, for the binding positions +con2tag_RDR tycon = mk_tc_deriv_name tycon "con2tag_" +tag2con_RDR tycon = mk_tc_deriv_name tycon "tag2con_" +maxtag_RDR tycon = mk_tc_deriv_name tycon "maxtag_" -con2tag_RDR tycon = varUnqual (mkFastString ("con2tag_" ++ occNameString (getOccName tycon) ++ "#")) -tag2con_RDR tycon = varUnqual (mkFastString ("tag2con_" ++ occNameString (getOccName tycon) ++ "#")) -maxtag_RDR tycon = varUnqual (mkFastString ("maxtag_" ++ occNameString (getOccName tycon) ++ "#")) +mk_tc_deriv_name tycon str + = mkDerivedRdrName tc_name mk_occ + where + tc_name = tyConName tycon + mk_occ tc_occ = mkOccFS varName (mkFastString new_str) + where + new_str = str ++ occNameString tc_occ ++ "#" \end{code} RdrNames for PrimOps. Can't be done in PrelNames, because PrimOp imports PrelNames, so PrelNames can't import PrimOp. \begin{code} -minusInt_RDR = nameRdrName minusIntName -eqInt_RDR = nameRdrName eqIntName -ltInt_RDR = nameRdrName ltIntName -geInt_RDR = nameRdrName geIntName -leInt_RDR = nameRdrName leIntName -eqChar_RDR = nameRdrName eqCharName -eqWord_RDR = nameRdrName eqWordName -eqAddr_RDR = nameRdrName eqAddrName -eqFloat_RDR = nameRdrName eqFloatName -eqDouble_RDR = nameRdrName eqDoubleName -ltChar_RDR = nameRdrName ltCharName -ltWord_RDR = nameRdrName ltWordName -ltAddr_RDR = nameRdrName ltAddrName -ltFloat_RDR = nameRdrName ltFloatName -ltDouble_RDR = nameRdrName ltDoubleName -tagToEnum_RDR = nameRdrName tagToEnumName +primOpRdrName op = getRdrName (primOpId op) + +minusInt_RDR = primOpRdrName IntSubOp +eqInt_RDR = primOpRdrName IntEqOp +ltInt_RDR = primOpRdrName IntLtOp +geInt_RDR = primOpRdrName IntGeOp +leInt_RDR = primOpRdrName IntLeOp +tagToEnum_RDR = primOpRdrName TagToEnumOp + +error_RDR = getRdrName eRROR_ID \end{code} diff --git a/ghc/compiler/typecheck/TcHsSyn.lhs b/ghc/compiler/typecheck/TcHsSyn.lhs index bb84ca8af7..dcdb63a718 100644 --- a/ghc/compiler/typecheck/TcHsSyn.lhs +++ b/ghc/compiler/typecheck/TcHsSyn.lhs @@ -60,7 +60,7 @@ import TcMType ( zonkTcTyVarToTyVar, zonkType, zonkTcType, zonkTcTyVars, import TysPrim ( charPrimTy, intPrimTy, floatPrimTy, doublePrimTy, addrPrimTy ) -import TysWiredIn ( charTy, stringTy, intTy, integerTy, +import TysWiredIn ( charTy, stringTy, intTy, mkListTy, mkPArrTy, mkTupleTy, unitTy, voidTy, listTyCon, tupleTyCon ) import TyCon ( mkPrimTyCon, tyConKind ) @@ -187,7 +187,7 @@ hsLitType (HsString str) = stringTy hsLitType (HsStringPrim s) = addrPrimTy hsLitType (HsInt i) = intTy hsLitType (HsIntPrim i) = intPrimTy -hsLitType (HsInteger i) = integerTy +hsLitType (HsInteger i ty) = ty hsLitType (HsRat _ ty) = ty hsLitType (HsFloatPrim f) = floatPrimTy hsLitType (HsDoublePrim d) = doublePrimTy @@ -828,7 +828,7 @@ zonkPat env (ConPatOut n stuff ty tvs dicts) let env1 = extendZonkEnv env new_dicts in - zonkConStuff env stuff `thenM` \ (new_stuff, ids) -> + zonkConStuff env1 stuff `thenM` \ (new_stuff, ids) -> returnM (ConPatOut n new_stuff new_ty new_tvs new_dicts, listToBag new_dicts `unionBags` ids) @@ -948,9 +948,6 @@ zonkRule env (HsRule name act vars lhs rhs loc) zonk_bndr (RuleBndr v) | isId v = zonkIdBndr env v | otherwise = zonkTcTyVarToTyVar v - -zonkRule env (IfaceRuleOut fun rule) - = returnM (IfaceRuleOut (zonkIdOcc env fun) rule) \end{code} diff --git a/ghc/compiler/typecheck/TcIfaceSig.lhs b/ghc/compiler/typecheck/TcIfaceSig.lhs deleted file mode 100644 index ebfdb499be..0000000000 --- a/ghc/compiler/typecheck/TcIfaceSig.lhs +++ /dev/null @@ -1,425 +0,0 @@ -% -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 -% -\section[TcIfaceSig]{Type checking of type signatures in interface files} - -\begin{code} -module TcIfaceSig ( tcInterfaceSigs, - tcCoreExpr, - tcCoreLamBndrs, - tcCoreBinds ) where - -#include "HsVersions.h" - -import HsSyn ( CoreDecl(..), TyClDecl(..), HsTupCon(..) ) -import TcHsSyn ( TypecheckedCoreBind ) -import TcRnTypes -import TcRnMonad -import TcMonoType ( tcIfaceType, kcHsSigType ) -import TcEnv ( tcExtendTyVarEnv, tcExtendGlobalValEnv, tcLookupGlobalId, - tcLookupDataCon ) - -import RnHsSyn ( RenamedCoreDecl, RenamedTyClDecl ) -import HsCore -import Literal ( Literal(..) ) -import CoreSyn -import CoreUtils ( exprType ) -import CoreUnfold -import CoreLint ( lintUnfolding ) -import WorkWrap ( mkWrapper ) - -import Id ( Id, mkVanillaGlobal, mkLocalId ) -import MkId ( mkFCallId ) -import IdInfo -import TyCon ( tyConDataCons, tyConTyVars ) -import DataCon ( DataCon, dataConWorkId, dataConExistentialTyVars, dataConArgTys ) -import Type ( mkTyVarTys, splitTyConApp ) -import TysWiredIn ( tupleCon ) -import Var ( mkTyVar, tyVarKind ) -import Name ( Name ) -import UniqSupply ( initUs_ ) -import Outputable -import Util ( zipWithEqual, dropList, equalLength ) -import HscTypes ( typeEnvIds ) -import CmdLineOpts ( DynFlag(..) ) -\end{code} - -Ultimately, type signatures in interfaces will have pragmatic -information attached, so it is a good idea to have separate code to -check them. - -As always, we do not have to worry about user-pragmas in interface -signatures. - -\begin{code} -tcInterfaceSigs :: [RenamedTyClDecl] -- Ignore non-sig-decls in these decls - -> TcM TcGblEnv - --- May 2003: --- NOTE 1: careful about the side-effected EPS --- in the two tcExtendGlobalValueEnv calls --- NOTE 2: no point in tying the knot with fixM; all --- the important knot-tying comes via the PCS global variable - -tcInterfaceSigs decls = - zapEnv (fixM (tc_interface_sigs decls)) `thenM` \ (_,sig_ids) -> - -- The zapEnv dramatically trims the environment, solely - -- to plug the space leak that would otherwise be caused - -- by a rich environment bound into lots of lazy thunks - -- The thunks are the lazily-typechecked IdInfo of the - -- imported things. - - tcExtendGlobalValEnv sig_ids getGblEnv `thenM` \ gbl_env -> - returnM gbl_env - -- We tie a knot so that the Ids read out of interfaces are in scope - -- when we read their pragmas. - -- What we rely on is that pragmas are typechecked lazily; if - -- any type errors are found (ie there's an inconsistency) - -- we silently discard the pragma - -- - -- NOTE ALSO: the knot is in two parts: - -- * Ids defined in this module are added to the typechecker envt - -- which is knot-tied by the fixM. - -- * Imported Ids are side-effected into the PCS by the - -- tcExtendGlobalValueEnv, so they will be seen there provided - -- we don't look them up too early. - -- In both cases, we must defer lookups until after the knot is tied - -- - -- We used to have a much bigger loop (in TcRnDriver), so that the - -- interface pragmas could mention variables bound in this module - -- (by mutual recn), but - -- (a) the knot is tiresomely big, and - -- (b) it black-holes when we have Template Haskell - -- - -- For (b) consider: f = $(...h....) - -- where h is imported, and calls f via an hi-boot file. - -- This is bad! But it is not seen as a staging error, because h - -- is indeed imported. We don't want the type-checker to black-hole - -- when simplifying and compiling the splice! - -- - -- Simple solution: discard any unfolding that mentions a variable - -- bound in this module (and hence not yet processed). - -- The discarding happens when forkM finds a type error. - -tc_interface_sigs decls ~(unf_env, _) - = sequenceM [do_one d | d@(IfaceSig {}) <- decls] `thenM` \ sig_ids -> - tcExtendGlobalValEnv sig_ids getGblEnv `thenM` \ gbl_env -> - returnM (gbl_env, sig_ids) - where - in_scope_vars = typeEnvIds (tcg_type_env unf_env) - -- When we have hi-boot files, an unfolding might refer to - -- something defined in this module, so we must build a - -- suitable in-scope set. This thunk will only be poked - -- if -dcore-lint is on. - - do_one IfaceSig {tcdName = name, tcdType = ty, - tcdIdInfo = id_infos, tcdLoc = src_loc} - = addSrcLoc src_loc $ - addErrCtxt (ifaceSigCtxt name) $ - tcIfaceType ty `thenM` \ sigma_ty -> - tcIdInfo unf_env in_scope_vars name - sigma_ty id_infos `thenM` \ id_info -> - returnM (mkVanillaGlobal name sigma_ty id_info) -\end{code} - -\begin{code} -tcIdInfo unf_env in_scope_vars name ty info_ins - = setGblEnv unf_env $ - -- Use the knot-tied environment for the IdInfo - -- In particular: typechecking unfoldings and worker names - foldlM tcPrag init_info info_ins - where - -- Set the CgInfo to something sensible but uninformative before - -- we start; default assumption is that it has CAFs - init_info = vanillaIdInfo - - tcPrag info HsNoCafRefs = returnM (info `setCafInfo` NoCafRefs) - tcPrag info (HsArity arity) = returnM (info `setArityInfo` arity) - tcPrag info (HsStrictness str) = returnM (info `setAllStrictnessInfo` Just str) - tcPrag info (HsWorker nm arity) = tcWorkerInfo ty info nm arity - - tcPrag info (HsUnfold inline_prag expr) - = tcPragExpr name in_scope_vars expr `thenM` \ maybe_expr' -> - let - -- maybe_expr' doesn't get looked at if the unfolding - -- is never inspected; so the typecheck doesn't even happen - unfold_info = case maybe_expr' of - Nothing -> noUnfolding - Just expr' -> mkTopUnfolding expr' - in - returnM (info `setUnfoldingInfoLazily` unfold_info - `setInlinePragInfo` inline_prag) -\end{code} - -\begin{code} -tcWorkerInfo ty info wkr_name arity - = forkM doc (tcVar wkr_name) `thenM` \ maybe_wkr_id -> - -- Watch out! We can't pull on unf_env too eagerly! - -- Hence the forkM - - -- We return without testing maybe_wkr_id, but as soon as info is - -- looked at we will test it. That's ok, because its outside the - -- knot; and there seems no big reason to further defer the - -- tcVar lookup. (Contrast with tcPragExpr, where postponing walking - -- over the unfolding until it's actually used does seem worth while.) - newUniqueSupply `thenM` \ us -> - returnM (case maybe_wkr_id of - Nothing -> info - Just wkr_id -> info `setUnfoldingInfoLazily` mk_unfolding us wkr_id - `setWorkerInfo` HasWorker wkr_id arity) - - where - doc = text "worker for" <+> ppr wkr_name - - mk_unfolding us wkr_id = mkTopUnfolding (initUs_ us (mkWrapper ty strict_sig) wkr_id) - - -- We are relying here on strictness info always appearing - -- before worker info, fingers crossed .... - strict_sig = case newStrictnessInfo info of - Just sig -> sig - Nothing -> pprPanic "Worker info but no strictness for" (ppr wkr_name) -\end{code} - -For unfoldings we try to do the job lazily, so that we never type check -an unfolding that isn't going to be looked at. - -\begin{code} -tcPragExpr :: Name -> [Id] -> UfExpr Name -> TcM (Maybe CoreExpr) -tcPragExpr name in_scope_vars expr - = forkM doc $ - tcCoreExpr expr `thenM` \ core_expr' -> - - -- Check for type consistency in the unfolding - ifOptM Opt_DoCoreLinting ( - getSrcLocM `thenM` \ src_loc -> - case lintUnfolding src_loc in_scope_vars core_expr' of - Nothing -> returnM () - Just fail_msg -> failWithTc ((doc <+> text "Failed Lint") $$ fail_msg) - ) `thenM_` - - returnM core_expr' - where - doc = text "unfolding of" <+> ppr name -\end{code} - - -Variables in unfoldings -~~~~~~~~~~~~~~~~~~~~~~~ - -\begin{code} -tcVar :: Name -> TcM Id - -- Inside here we use only the Global environment, even for locally bound variables. - -- Why? Because we know all the types and want to bind them to real Ids. -tcVar name = tcLookupGlobalId name -\end{code} - -UfCore expressions. - -\begin{code} -tcCoreExpr :: UfExpr Name -> TcM CoreExpr - -tcCoreExpr (UfType ty) - = tcIfaceType ty `thenM` \ ty' -> - -- It might not be of kind type - returnM (Type ty') - -tcCoreExpr (UfVar name) - = tcVar name `thenM` \ id -> - returnM (Var id) - -tcCoreExpr (UfLit lit) - = returnM (Lit lit) - -tcCoreExpr (UfFCall cc ty) - = tcIfaceType ty `thenM` \ ty' -> - newUnique `thenM` \ u -> - returnM (Var (mkFCallId u cc ty')) - -tcCoreExpr (UfTuple (HsTupCon boxity arity) args) - = mappM tcCoreExpr args `thenM` \ args' -> - let - -- Put the missing type arguments back in - con_args = map (Type . exprType) args' ++ args' - in - returnM (mkApps (Var con_id) con_args) - where - con_id = dataConWorkId (tupleCon boxity arity) - - -tcCoreExpr (UfLam bndr body) - = tcCoreLamBndr bndr $ \ bndr' -> - tcCoreExpr body `thenM` \ body' -> - returnM (Lam bndr' body') - -tcCoreExpr (UfApp fun arg) - = tcCoreExpr fun `thenM` \ fun' -> - tcCoreExpr arg `thenM` \ arg' -> - returnM (App fun' arg') - -tcCoreExpr (UfCase scrut case_bndr alts) - = tcCoreExpr scrut `thenM` \ scrut' -> - let - scrut_ty = exprType scrut' - case_bndr' = mkLocalId case_bndr scrut_ty - in - tcExtendGlobalValEnv [case_bndr'] $ - mappM (tcCoreAlt scrut_ty) alts `thenM` \ alts' -> - returnM (Case scrut' case_bndr' alts') - -tcCoreExpr (UfLet (UfNonRec bndr rhs) body) - = tcCoreExpr rhs `thenM` \ rhs' -> - tcCoreValBndr bndr $ \ bndr' -> - tcCoreExpr body `thenM` \ body' -> - returnM (Let (NonRec bndr' rhs') body') - -tcCoreExpr (UfLet (UfRec pairs) body) - = tcCoreValBndrs bndrs $ \ bndrs' -> - mappM tcCoreExpr rhss `thenM` \ rhss' -> - tcCoreExpr body `thenM` \ body' -> - returnM (Let (Rec (bndrs' `zip` rhss')) body') - where - (bndrs, rhss) = unzip pairs - -tcCoreExpr (UfNote note expr) - = tcCoreExpr expr `thenM` \ expr' -> - case note of - UfCoerce to_ty -> tcIfaceType to_ty `thenM` \ to_ty' -> - returnM (Note (Coerce to_ty' - (exprType expr')) expr') - UfInlineCall -> returnM (Note InlineCall expr') - UfInlineMe -> returnM (Note InlineMe expr') - UfSCC cc -> returnM (Note (SCC cc) expr') -\end{code} - -\begin{code} -tcCoreLamBndr (UfValBinder name ty) thing_inside - = tcIfaceType ty `thenM` \ ty' -> - let - id = mkLocalId name ty' - in - tcExtendGlobalValEnv [id] $ - thing_inside id - -tcCoreLamBndr (UfTyBinder name kind) thing_inside - = let - tyvar = mkTyVar name kind - in - tcExtendTyVarEnv [tyvar] (thing_inside tyvar) - -tcCoreLamBndrs [] thing_inside = thing_inside [] -tcCoreLamBndrs (b:bs) thing_inside - = tcCoreLamBndr b $ \ b' -> - tcCoreLamBndrs bs $ \ bs' -> - thing_inside (b':bs') - -tcCoreValBndr (UfValBinder name ty) thing_inside - = tcIfaceType ty `thenM` \ ty' -> - let - id = mkLocalId name ty' - in - tcExtendGlobalValEnv [id] $ - thing_inside id - -tcCoreValBndrs bndrs thing_inside -- Expect them all to be ValBinders - = mappM tcIfaceType tys `thenM` \ tys' -> - let - ids = zipWithEqual "tcCoreValBndr" mkLocalId names tys' - in - tcExtendGlobalValEnv ids $ - thing_inside ids - where - names = [name | UfValBinder name _ <- bndrs] - tys = [ty | UfValBinder _ ty <- bndrs] -\end{code} - -\begin{code} -tcCoreAlt scrut_ty (UfDefault, names, rhs) - = ASSERT( null names ) - tcCoreExpr rhs `thenM` \ rhs' -> - returnM (DEFAULT, [], rhs') - -tcCoreAlt scrut_ty (UfLitAlt lit, names, rhs) - = ASSERT( null names ) - tcCoreExpr rhs `thenM` \ rhs' -> - returnM (LitAlt lit, [], rhs') - --- A case alternative is made quite a bit more complicated --- by the fact that we omit type annotations because we can --- work them out. True enough, but its not that easy! -tcCoreAlt scrut_ty alt@(con, names, rhs) - = tcConAlt con `thenM` \ con -> - let - ex_tyvars = dataConExistentialTyVars con - (tycon, inst_tys) = splitTyConApp scrut_ty -- NB: not tcSplitTyConApp - -- We are looking at Core here - main_tyvars = tyConTyVars tycon - ex_tyvars' = [mkTyVar name (tyVarKind tv) | (name,tv) <- names `zip` ex_tyvars] - ex_tys' = mkTyVarTys ex_tyvars' - arg_tys = dataConArgTys con (inst_tys ++ ex_tys') - id_names = dropList ex_tyvars names - arg_ids -#ifdef DEBUG - | not (equalLength id_names arg_tys) - = pprPanic "tcCoreAlts" (ppr (con, names, rhs) $$ - (ppr main_tyvars <+> ppr ex_tyvars) $$ - ppr arg_tys) - | otherwise -#endif - = zipWithEqual "tcCoreAlts" mkLocalId id_names arg_tys - in - ASSERT( con `elem` tyConDataCons tycon && equalLength inst_tys main_tyvars ) - tcExtendTyVarEnv ex_tyvars' $ - tcExtendGlobalValEnv arg_ids $ - tcCoreExpr rhs `thenM` \ rhs' -> - returnM (DataAlt con, ex_tyvars' ++ arg_ids, rhs') - - -tcConAlt :: UfConAlt Name -> TcM DataCon -tcConAlt (UfTupleAlt (HsTupCon boxity arity)) - = returnM (tupleCon boxity arity) - -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} - -%************************************************************************ -%* * -\subsection{Core decls} -%* * -%************************************************************************ - - -\begin{code} -tcCoreBinds :: [RenamedCoreDecl] -> TcM [TypecheckedCoreBind] --- We don't assume the bindings are in dependency order --- So first build the environment, then check the RHSs -tcCoreBinds ls = mappM tcCoreBinder ls `thenM` \ bndrs -> - tcExtendGlobalValEnv bndrs $ - mappM (tcCoreBind bndrs) ls - -tcCoreBinder (CoreDecl nm ty _ _) - = kcHsSigType ty `thenM_` - tcIfaceType ty `thenM` \ ty' -> - returnM (mkLocalId nm ty') - -tcCoreBind bndrs (CoreDecl nm _ rhs loc) - = tcVar nm `thenM` \ id -> - tcCoreExpr rhs `thenM` \ rhs' -> - let - mb_err = lintUnfolding loc bndrs rhs' - in - (case mb_err of - Just err -> addErr err - Nothing -> returnM ()) `thenM_` - - returnM (id, rhs') -\end{code} - - -\begin{code} -ifaceSigCtxt sig_name - = hsep [ptext SLIT("In an interface-file signature for"), ppr sig_name] -\end{code} - diff --git a/ghc/compiler/typecheck/TcInstDcls.lhs b/ghc/compiler/typecheck/TcInstDcls.lhs index d35c0de5aa..8bb47542f9 100644 --- a/ghc/compiler/typecheck/TcInstDcls.lhs +++ b/ghc/compiler/typecheck/TcInstDcls.lhs @@ -4,69 +4,50 @@ \section[TcInstDecls]{Typechecking instance declarations} \begin{code} -module TcInstDcls ( tcInstDecls1, tcIfaceInstDecls, - tcInstDecls2, tcAddDeclCtxt ) where +module TcInstDcls ( tcInstDecls1, tcInstDecls2 ) where #include "HsVersions.h" - -import CmdLineOpts ( DynFlag(..) ) - -import HsSyn ( InstDecl(..), TyClDecl(..), HsType(..), - MonoBinds(..), HsExpr(..), HsLit(..), Sig(..), HsTyVarBndr(..), +import HsSyn ( InstDecl(..), HsType(..), + MonoBinds(..), HsExpr(..), HsLit(..), Sig(..), andMonoBindList, collectMonoBinders, - isClassDecl, isSourceInstDecl, toHsType - ) -import RnHsSyn ( RenamedHsBinds, RenamedInstDecl, - RenamedMonoBinds, RenamedTyClDecl, RenamedHsType, - extractHsTyVars, maybeGenericMatch + isClassDecl ) +import RnHsSyn ( RenamedHsBinds, RenamedInstDecl, RenamedTyClDecl ) import TcHsSyn ( TcMonoBinds, mkHsConApp ) import TcBinds ( tcSpecSigs ) -import TcClassDcl ( tcMethodBind, mkMethodBind, badMethodErr ) +import TcClassDcl ( tcMethodBind, mkMethodBind, badMethodErr, + tcClassDecl2, getGenericInstances ) import TcRnMonad import TcMType ( tcInstType, checkValidTheta, checkValidInstHead, instTypeErr, - checkAmbiguity, UserTypeCtxt(..), SourceTyCtxt(..) ) -import TcType ( mkClassPred, mkTyVarTy, tcSplitForAllTys, tyVarsOfType, + checkAmbiguity, SourceTyCtxt(..) ) +import TcType ( mkClassPred, tcSplitForAllTys, tyVarsOfType, tcSplitSigmaTy, getClassPredTys, tcSplitPredTy_maybe, mkTyVarTys, - TyVarDetails(..) + TyVarDetails(..), tcSplitDFunTy ) -import Inst ( InstOrigin(..), tcInstClassOp, newDicts, instToId, showLIE ) +import Inst ( InstOrigin(..), tcInstClassOp, newDicts, instToId, + showLIE, tcExtendLocalInstEnv ) import TcDeriv ( tcDeriving ) -import TcEnv ( tcExtendGlobalValEnv, - tcLookupClass, tcExtendTyVarEnv2, - tcExtendInstEnv, tcExtendLocalInstEnv, tcLookupGlobalId, - InstInfo(..), InstBindings(..), pprInstInfo, simpleInstInfoTyCon, - simpleInstInfoTy, newDFunName +import TcEnv ( tcExtendGlobalValEnv, tcExtendTyVarEnv2, + InstInfo(..), InstBindings(..), + newDFunName, tcExtendLocalValEnv ) import PprType ( pprClassPred ) -import TcMonoType ( tcHsTyVars, kcHsSigType, tcHsType, tcHsSigType ) +import TcHsType ( kcHsSigType, tcHsKindedType ) import TcUnify ( checkSigTyVars ) import TcSimplify ( tcSimplifyCheck, tcSimplifyTop ) -import HscTypes ( DFunId ) import Subst ( mkTyVarSubst, substTheta, substTy ) import DataCon ( classDataCon ) -import Class ( Class, classBigSig ) +import Class ( classBigSig ) import Var ( idName, idType ) import NameSet import MkId ( mkDictFunId, rUNTIME_ERROR_ID ) import FunDeps ( checkInstFDs ) -import Generics ( validGenericInstanceType ) import Name ( getSrcLoc ) import NameSet ( unitNameSet, emptyNameSet, nameSetToList ) -import TyCon ( TyCon ) -import TysWiredIn ( genericTyCons ) -import SrcLoc ( SrcLoc ) -import Unique ( Uniquable(..) ) -import Util ( lengthExceeds ) -import BasicTypes ( NewOrData(..) ) import UnicodeUtil ( stringToUtf8 ) -import ErrUtils ( dumpIfSet_dyn ) -import ListSetOps ( Assoc, emptyAssoc, plusAssoc_C, mapAssoc, - assocElts, extendAssoc_C, equivClassesByUniq, minusList - ) import Maybe ( catMaybes ) -import List ( partition ) +import ListSetOps ( minusList ) import Outputable import FastString \end{code} @@ -160,23 +141,15 @@ tcInstDecls1 -- Deal with both source-code and imported instance decls -> TcM (TcGblEnv, -- The full inst env [InstInfo], -- Source-code instance decls to process; -- contains all dfuns for this module - RenamedHsBinds, -- Supporting bindings for derived instances - FreeVars) -- And the free vars of the derived code + RenamedHsBinds) -- Supporting bindings for derived instances tcInstDecls1 tycl_decls inst_decls = checkNoErrs $ -- Stop if addInstInfos etc discovers any errors -- (they recover, so that we get more than one error each round) - let - (src_inst_decls, iface_inst_decls) = partition isSourceInstDecl inst_decls - in - - -- (0) Deal with the imported instance decls - tcIfaceInstDecls iface_inst_decls `thenM` \ imp_dfuns -> - tcExtendInstEnv imp_dfuns $ -- (1) Do the ordinary instance declarations - mappM tcLocalInstDecl1 src_inst_decls `thenM` \ local_inst_infos -> + mappM tcLocalInstDecl1 inst_decls `thenM` \ local_inst_infos -> let local_inst_info = catMaybes local_inst_infos @@ -189,21 +162,23 @@ tcInstDecls1 tycl_decls inst_decls -- a) imported instance decls (from this module) -- b) local instance decls -- c) generic instances - tcExtendLocalInstEnv local_inst_info $ - tcExtendLocalInstEnv generic_inst_info $ + addInsts local_inst_info $ + addInsts generic_inst_info $ -- (3) Compute instances from "deriving" clauses; - -- note that we only do derivings for things in this module; - -- we ignore deriving decls from interfaces! -- This stuff computes a context for the derived instance decl, so it -- needs to know about all the instances possible; hence inst_env4 - tcDeriving tycl_decls `thenM` \ (deriv_inst_info, deriv_binds, fvs) -> - tcExtendLocalInstEnv deriv_inst_info $ + tcDeriving tycl_decls `thenM` \ (deriv_inst_info, deriv_binds) -> + addInsts deriv_inst_info $ - getGblEnv `thenM` \ gbl_env -> + getGblEnv `thenM` \ gbl_env -> returnM (gbl_env, generic_inst_info ++ deriv_inst_info ++ local_inst_info, - deriv_binds, fvs) + deriv_binds) + +addInsts :: [InstInfo] -> TcM a -> TcM a +addInsts infos thing_inside + = tcExtendLocalInstEnv (map iDFunId infos) thing_inside \end{code} \begin{code} @@ -217,16 +192,16 @@ tcLocalInstDecl1 :: RenamedInstDecl -- Imported ones should have been checked already, and may indeed -- contain something illegal in normal Haskell, notably -- instance CCallable [Char] -tcLocalInstDecl1 decl@(InstDecl poly_ty binds uprags Nothing src_loc) +tcLocalInstDecl1 decl@(InstDecl poly_ty binds uprags src_loc) = -- Prime error recovery, set source location recoverM (returnM Nothing) $ addSrcLoc src_loc $ - addErrCtxt (instDeclCtxt poly_ty) $ + addErrCtxt (instDeclCtxt1 poly_ty) $ -- Typecheck the instance type itself. We can't use -- tcHsSigType, because it's not a valid user type. - kcHsSigType poly_ty `thenM_` - tcHsType poly_ty `thenM` \ poly_ty' -> + kcHsSigType poly_ty `thenM` \ kinded_ty -> + tcHsKindedType kinded_ty `thenM` \ poly_ty' -> let (tyvars, theta, tau) = tcSplitSigmaTy poly_ty' in @@ -242,163 +217,6 @@ tcLocalInstDecl1 decl@(InstDecl poly_ty binds uprags Nothing src_loc) msg = parens (ptext SLIT("the instance types do not agree with the functional dependencies of the class")) \end{code} -Imported instance declarations - -\begin{code} -tcIfaceInstDecls :: [RenamedInstDecl] -> TcM [DFunId] --- Deal with the instance decls, -tcIfaceInstDecls decls = mappM tcIfaceInstDecl decls - -tcIfaceInstDecl :: RenamedInstDecl -> TcM DFunId - -- An interface-file instance declaration - -- Should be in scope by now, because we should - -- have sucked in its interface-file definition - -- So it will be replete with its unfolding etc -tcIfaceInstDecl decl@(InstDecl poly_ty binds uprags (Just dfun_name) src_loc) - = tcLookupGlobalId dfun_name -\end{code} - - -%************************************************************************ -%* * -\subsection{Extracting generic instance declaration from class declarations} -%* * -%************************************************************************ - -@getGenericInstances@ extracts the generic instance declarations from a class -declaration. For exmaple - - class C a where - op :: a -> a - - op{ x+y } (Inl v) = ... - op{ x+y } (Inr v) = ... - op{ x*y } (v :*: w) = ... - op{ 1 } Unit = ... - -gives rise to the instance declarations - - instance C (x+y) where - op (Inl v) = ... - op (Inr v) = ... - - instance C (x*y) where - op (v :*: w) = ... - - instance C 1 where - op Unit = ... - - -\begin{code} -getGenericInstances :: [RenamedTyClDecl] -> TcM [InstInfo] -getGenericInstances class_decls - = mappM get_generics class_decls `thenM` \ gen_inst_infos -> - let - gen_inst_info = concat gen_inst_infos - in - if null gen_inst_info then - returnM [] - else - getDOpts `thenM` \ dflags -> - ioToTcRn (dumpIfSet_dyn dflags Opt_D_dump_deriv "Generic instances" - (vcat (map pprInstInfo gen_inst_info))) - `thenM_` - returnM gen_inst_info - -get_generics decl@(ClassDecl {tcdMeths = Nothing}) - = returnM [] -- Imported class decls - -get_generics decl@(ClassDecl {tcdName = class_name, tcdMeths = Just def_methods, tcdLoc = loc}) - | null groups - = returnM [] -- The comon case: no generic default methods - - | otherwise -- A source class decl with generic default methods - = recoverM (returnM []) $ - tcAddDeclCtxt decl $ - tcLookupClass class_name `thenM` \ clas -> - - -- Make an InstInfo out of each group - mappM (mkGenericInstance clas loc) groups `thenM` \ inst_infos -> - - -- Check that there is only one InstInfo for each type constructor - -- The main way this can fail is if you write - -- f {| a+b |} ... = ... - -- f {| x+y |} ... = ... - -- Then at this point we'll have an InstInfo for each - let - tc_inst_infos :: [(TyCon, InstInfo)] - tc_inst_infos = [(simpleInstInfoTyCon i, i) | i <- inst_infos] - - bad_groups = [group | group <- equivClassesByUniq get_uniq tc_inst_infos, - group `lengthExceeds` 1] - get_uniq (tc,_) = getUnique tc - in - mappM (addErrTc . dupGenericInsts) bad_groups `thenM_` - - -- Check that there is an InstInfo for each generic type constructor - let - missing = genericTyCons `minusList` [tc | (tc,_) <- tc_inst_infos] - in - checkTc (null missing) (missingGenericInstances missing) `thenM_` - - returnM inst_infos - - where - -- Group the declarations by type pattern - groups :: [(RenamedHsType, RenamedMonoBinds)] - groups = assocElts (getGenericBinds def_methods) - - ---------------------------------- -getGenericBinds :: RenamedMonoBinds -> Assoc RenamedHsType RenamedMonoBinds - -- Takes a group of method bindings, finds the generic ones, and returns - -- them in finite map indexed by the type parameter in the definition. - -getGenericBinds EmptyMonoBinds = emptyAssoc -getGenericBinds (AndMonoBinds m1 m2) - = plusAssoc_C AndMonoBinds (getGenericBinds m1) (getGenericBinds m2) - -getGenericBinds (FunMonoBind id infixop matches loc) - = mapAssoc wrap (foldl add emptyAssoc matches) - -- Using foldl not foldr is vital, else - -- we reverse the order of the bindings! - where - add env match = case maybeGenericMatch match of - Nothing -> env - Just (ty, match') -> extendAssoc_C (++) env (ty, [match']) - - wrap ms = FunMonoBind id infixop ms loc - ---------------------------------- -mkGenericInstance :: Class -> SrcLoc - -> (RenamedHsType, RenamedMonoBinds) - -> TcM InstInfo - -mkGenericInstance clas loc (hs_ty, binds) - -- Make a generic instance declaration - -- For example: instance (C a, C b) => C (a+b) where { binds } - - = -- Extract the universally quantified type variables - let - sig_tvs = map UserTyVar (nameSetToList (extractHsTyVars hs_ty)) - in - tcHsTyVars sig_tvs (kcHsSigType hs_ty) $ \ tyvars -> - - -- Type-check the instance type, and check its form - tcHsSigType GenPatCtxt hs_ty `thenM` \ inst_ty -> - checkTc (validGenericInstanceType inst_ty) - (badGenericInstanceType binds) `thenM_` - - -- Make the dictionary function. - newDFunName clas [inst_ty] loc `thenM` \ dfun_name -> - let - inst_theta = [mkClassPred clas [mkTyVarTy tv] | tv <- tyvars] - dfun_id = mkDictFunId dfun_name tyvars inst_theta clas [inst_ty] - in - - returnM (InstInfo { iDFunId = dfun_id, iBinds = VanillaInst binds [] }) -\end{code} - %************************************************************************ %* * @@ -407,10 +225,26 @@ mkGenericInstance clas loc (hs_ty, binds) %************************************************************************ \begin{code} -tcInstDecls2 :: [InstInfo] -> TcM TcMonoBinds -tcInstDecls2 inst_decls - = mappM tcInstDecl2 inst_decls `thenM` \ binds_s -> - returnM (andMonoBindList binds_s) +tcInstDecls2 :: [RenamedTyClDecl] -> [InstInfo] + -> TcM (TcLclEnv, TcMonoBinds) +-- (a) From each class declaration, +-- generate any default-method bindings +-- (b) From each instance decl +-- generate the dfun binding + +tcInstDecls2 tycl_decls inst_decls + = do { -- (a) Default methods from class decls + (dm_binds_s, dm_ids_s) <- mapAndUnzipM tcClassDecl2 $ + filter isClassDecl tycl_decls + ; tcExtendLocalValEnv (concat dm_ids_s) $ do + + -- (b) instance declarations + ; inst_binds_s <- mappM tcInstDecl2 inst_decls + + -- Done + ; tcl_env <- getLclEnv + ; returnM (tcl_env, andMonoBindList dm_binds_s `AndMonoBinds` + andMonoBindList inst_binds_s) } \end{code} ======= New documentation starts here (Sept 92) ============== @@ -485,9 +319,9 @@ tcInstDecl2 :: InstInfo -> TcM TcMonoBinds tcInstDecl2 (InstInfo { iDFunId = dfun_id, iBinds = binds }) = -- Prime error recovery - recoverM (returnM EmptyMonoBinds) $ - addSrcLoc (getSrcLoc dfun_id) $ - addErrCtxt (instDeclCtxt (toHsType (idType dfun_id))) $ + recoverM (returnM EmptyMonoBinds) $ + addSrcLoc (getSrcLoc dfun_id) $ + addErrCtxt (instDeclCtxt2 (idType dfun_id)) $ let inst_ty = idType dfun_id (inst_tyvars, _) = tcSplitForAllTys inst_ty @@ -844,44 +678,17 @@ simplified: only zeze2 is extracted and its body is simplified. %************************************************************************ \begin{code} -tcAddDeclCtxt decl thing_inside - = addSrcLoc (tcdLoc decl) $ - addErrCtxt ctxt $ - thing_inside +instDeclCtxt1 hs_inst_ty + = inst_decl_ctxt (case hs_inst_ty of + HsForAllTy _ _ (HsPredTy pred) -> ppr pred + HsPredTy pred -> ppr pred + other -> ppr hs_inst_ty) -- Don't expect this +instDeclCtxt2 dfun_ty + = inst_decl_ctxt (ppr (mkClassPred cls tys)) where - thing = case decl of - ClassDecl {} -> "class" - TySynonym {} -> "type synonym" - TyData {tcdND = NewType} -> "newtype" - TyData {tcdND = DataType} -> "data type" - - ctxt = hsep [ptext SLIT("In the"), text thing, - ptext SLIT("declaration for"), quotes (ppr (tcdName decl))] - -instDeclCtxt inst_ty = ptext SLIT("In the instance declaration for") <+> quotes doc - where - doc = case inst_ty of - HsForAllTy _ _ (HsPredTy pred) -> ppr pred - HsPredTy pred -> ppr pred - other -> ppr inst_ty -- Don't expect this -\end{code} + (_,_,cls,tys) = tcSplitDFunTy dfun_ty + +inst_decl_ctxt doc = ptext SLIT("In the instance declaration for") <+> quotes doc -\begin{code} -badGenericInstanceType binds - = vcat [ptext SLIT("Illegal type pattern in the generic bindings"), - nest 4 (ppr binds)] - -missingGenericInstances missing - = ptext SLIT("Missing type patterns for") <+> pprQuotedList missing - -dupGenericInsts tc_inst_infos - = vcat [ptext SLIT("More than one type pattern for a single generic type constructor:"), - nest 4 (vcat (map ppr_inst_ty tc_inst_infos)), - ptext SLIT("All the type patterns for a generic type constructor must be identical") - ] - where - ppr_inst_ty (tc,inst) = ppr (simpleInstInfoTy inst) - -methodCtxt = ptext SLIT("When checking the methods of an instance declaration") superClassCtxt = ptext SLIT("When checking the super-classes of an instance declaration") \end{code} diff --git a/ghc/compiler/typecheck/TcMType.lhs b/ghc/compiler/typecheck/TcMType.lhs index cc45bf4a16..df9bd11344 100644 --- a/ghc/compiler/typecheck/TcMType.lhs +++ b/ghc/compiler/typecheck/TcMType.lhs @@ -14,7 +14,7 @@ module TcMType ( newTyVar, newSigTyVar, newTyVarTy, -- Kind -> TcM TcType newTyVarTys, -- Int -> Kind -> TcM [TcType] - newKindVar, newKindVars, newOpenTypeKind, + newKindVar, newKindVars, newBoxityVar, putTcTyVar, getTcTyVar, newMutTyVar, readMutTyVar, writeMutTyVar, @@ -25,17 +25,17 @@ module TcMType ( -------------------------------- -- Checking type validity Rank, UserTypeCtxt(..), checkValidType, pprUserTypeCtxt, - SourceTyCtxt(..), checkValidTheta, - checkValidTyCon, checkValidClass, + SourceTyCtxt(..), checkValidTheta, checkFreeness, checkValidInstHead, instTypeErr, checkAmbiguity, - arityErr, + arityErr, -------------------------------- -- Zonking zonkType, zonkTcTyVar, zonkTcTyVars, zonkTcTyVarsAndFV, zonkTcType, zonkTcTypes, zonkTcClassConstraints, zonkTcThetaType, - zonkTcPredType, zonkTcTyVarToTyVar, zonkKindEnv, + zonkTcPredType, zonkTcTyVarToTyVar, + zonkTcKindToKind ) where @@ -43,48 +43,41 @@ module TcMType ( -- friends: -import TypeRep ( Type(..), SourceType(..), TyNote(..), -- Friend; can see representation - Kind, ThetaType, typeCon +import TypeRep ( Type(..), PredType(..), TyNote(..), -- Friend; can see representation + Kind, ThetaType ) import TcType ( TcType, TcThetaType, TcTauType, TcPredType, TcTyVarSet, TcKind, TcTyVar, TyVarDetails(..), tcEqType, tcCmpPred, isClassPred, tcSplitPhiTy, tcSplitPredTy_maybe, tcSplitAppTy_maybe, tcSplitTyConApp_maybe, tcSplitForAllTys, - tcIsTyVarTy, tcSplitSigmaTy, mkTyConApp, + tcIsTyVarTy, tcSplitSigmaTy, isUnLiftedType, isIPPred, isTyVarTy, mkAppTy, mkTyVarTy, mkTyVarTys, tyVarsOfPred, getClassPredTys_maybe, - liftedTypeKind, openTypeKind, defaultKind, superKind, + liftedTypeKind, defaultKind, superKind, superBoxity, liftedBoxity, typeKind, tyVarsOfType, tyVarsOfTypes, eqKind, isTypeKind, - isFFIArgumentTy, isFFIImportResultTy ) import Subst ( Subst, mkTopTyVarSubst, substTy ) -import Class ( Class, DefMeth(..), classArity, className, classBigSig ) +import Class ( Class, classArity, className ) import TyCon ( TyCon, isSynTyCon, isUnboxedTupleTyCon, - tyConArity, tyConName, tyConTheta, - getSynTyConDefn, tyConDataCons ) -import DataCon ( DataCon, dataConWrapId, dataConName, dataConSig, dataConFieldLabels ) -import FieldLabel ( fieldLabelName, fieldLabelType ) -import Var ( TyVar, idType, idName, tyVarKind, tyVarName, isTyVar, + tyConArity, tyConName ) +import Var ( TyVar, tyVarKind, tyVarName, isTyVar, mkTyVar, mkMutTyVar, isMutTyVar, mutTyVarRef ) -- others: -import Generics ( validGenericMethodType ) import TcRnMonad -- TcType, amongst others -import PrelNames ( hasKey ) -import ForeignCall ( Safety(..) ) import FunDeps ( grow ) -import PprType ( pprPred, pprSourceType, pprTheta, pprClassPred ) +import PprType ( pprPred, pprTheta, pprClassPred ) import Name ( Name, setNameUnique, mkSystemTvNameEncoded ) import VarSet import CmdLineOpts ( dopt, DynFlag(..) ) -import Util ( nOfThem, isSingleton, equalLength, notNull, lengthExceeds ) -import ListSetOps ( equivClasses, removeDups ) +import Util ( nOfThem, isSingleton, equalLength, notNull ) +import ListSetOps ( removeDups ) import Outputable \end{code} @@ -134,11 +127,11 @@ newKindVar newKindVars :: Int -> TcM [TcKind] newKindVars n = mappM (\ _ -> newKindVar) (nOfThem n ()) -newOpenTypeKind :: TcM TcKind -- Returns the kind (Type bx), where bx is fresh -newOpenTypeKind - = newUnique `thenM` \ uniq -> - newMutTyVar (mkSystemTvNameEncoded uniq FSLIT("bx")) superBoxity VanillaTv `thenM` \ kv -> - returnM (mkTyConApp typeCon [TyVarTy kv]) +newBoxityVar :: TcM TcKind -- Really TcBoxity + = newUnique `thenM` \ uniq -> + newMutTyVar (mkSystemTvNameEncoded uniq FSLIT("bx")) + superBoxity VanillaTv `thenM` \ kv -> + returnM (TyVarTy kv) \end{code} @@ -319,19 +312,17 @@ zonkTcPredType (IParam n t) are used at the end of type checking \begin{code} -zonkKindEnv :: [(Name, TcKind)] -> TcM [(Name, Kind)] -zonkKindEnv pairs - = mappM zonk_it pairs - where - zonk_it (name, tc_kind) = zonkType zonk_unbound_kind_var tc_kind `thenM` \ kind -> - returnM (name, kind) - +zonkTcKindToKind :: TcKind -> TcM Kind +zonkTcKindToKind tc_kind + = zonkType zonk_unbound_kind_var tc_kind + where -- When zonking a kind, we want to -- zonk a *kind* variable to (Type *) -- zonk a *boxity* variable to * - zonk_unbound_kind_var kv | tyVarKind kv `eqKind` superKind = putTcTyVar kv liftedTypeKind - | tyVarKind kv `eqKind` superBoxity = putTcTyVar kv liftedBoxity - | otherwise = pprPanic "zonkKindEnv" (ppr kv) + zonk_unbound_kind_var kv + | tyVarKind kv `eqKind` superKind = putTcTyVar kv liftedTypeKind + | tyVarKind kv `eqKind` superBoxity = putTcTyVar kv liftedBoxity + | otherwise = pprPanic "zonkKindEnv" (ppr kv) -- zonkTcTyVarToTyVar is applied to the *binding* occurrence -- of a type variable, at the *end* of type checking. It changes @@ -421,14 +412,17 @@ zonkType unbound_var_fn ty go (TyConApp tycon tys) = mappM go tys `thenM` \ tys' -> returnM (TyConApp tycon tys') + go (NewTcApp tycon tys) = mappM go tys `thenM` \ tys' -> + returnM (NewTcApp tycon tys') + go (NoteTy (SynNote ty1) ty2) = go ty1 `thenM` \ ty1' -> go ty2 `thenM` \ ty2' -> returnM (NoteTy (SynNote ty1') ty2') go (NoteTy (FTVNote _) ty2) = go ty2 -- Discard free-tyvar annotations - go (SourceTy p) = go_pred p `thenM` \ p' -> - returnM (SourceTy p') + go (PredTy p) = go_pred p `thenM` \ p' -> + returnM (PredTy p') go (FunTy arg res) = go arg `thenM` \ arg' -> go res `thenM` \ res' -> @@ -450,8 +444,6 @@ zonkType unbound_var_fn ty go_pred (ClassP c tys) = mappM go tys `thenM` \ tys' -> returnM (ClassP c tys') - go_pred (NType tc tys) = mappM go tys `thenM` \ tys' -> - returnM (NType tc tys') go_pred (IParam n ty) = go ty `thenM` \ ty' -> returnM (IParam n ty') @@ -521,6 +513,7 @@ data UserTypeCtxt -- f x :: t = .... | ForSigCtxt Name -- Foreign inport or export signature | RuleSigCtxt Name -- Signature on a forall'd variable in a RULE + | DefaultDeclCtxt -- Types in a default declaration -- Notes re TySynCtxt -- We allow type synonyms that aren't types; e.g. type List = [] @@ -542,19 +535,22 @@ pprUserTypeCtxt PatSigCtxt = ptext SLIT("a pattern type signature") pprUserTypeCtxt ResSigCtxt = ptext SLIT("a result type signature") pprUserTypeCtxt (ForSigCtxt n) = ptext SLIT("the foreign signature for") <+> quotes (ppr n) pprUserTypeCtxt (RuleSigCtxt n) = ptext SLIT("the type signature on") <+> quotes (ppr n) +pprUserTypeCtxt DefaultDeclCtxt = ptext SLIT("a `default' declaration") \end{code} \begin{code} checkValidType :: UserTypeCtxt -> Type -> TcM () -- Checks that the type is valid for the given context checkValidType ctxt ty - = doptM Opt_GlasgowExts `thenM` \ gla_exts -> + = traceTc (text "checkValidType" <+> ppr ty) `thenM_` + doptM Opt_GlasgowExts `thenM` \ gla_exts -> let rank | gla_exts = Arbitrary | otherwise = case ctxt of -- Haskell 98 GenPatCtxt -> Rank 0 PatSigCtxt -> Rank 0 + DefaultDeclCtxt-> Rank 0 ResSigCtxt -> Rank 0 TySynCtxt _ -> Rank 0 ExprSigCtxt -> Rank 1 @@ -582,31 +578,13 @@ checkValidType ctxt ty -- but for type synonyms we allow them even at -- top level in - addErrCtxt (checkTypeCtxt ctxt ty) $ - -- Check that the thing has kind Type, and is lifted if necessary checkTc kind_ok (kindErr actual_kind) `thenM_` -- Check the internal validity of the type itself - check_poly_type rank ubx_tup ty - - -checkTypeCtxt ctxt ty - = vcat [ptext SLIT("In the type:") <+> ppr_ty ty, - ptext SLIT("While checking") <+> pprUserTypeCtxt ctxt ] - - -- Hack alert. If there are no tyvars, (ppr sigma_ty) will print - -- something strange like {Eq k} -> k -> k, because there is no - -- ForAll at the top of the type. Since this is going to the user - -- we want it to look like a proper Haskell type even then; hence the hack - -- - -- This shows up in the complaint about - -- case C a where - -- op :: Eq a => a -> a -ppr_ty ty | null forall_tvs && notNull theta = pprTheta theta <+> ptext SLIT("=>") <+> ppr tau - | otherwise = ppr ty - where - (forall_tvs, theta, tau) = tcSplitSigmaTy ty + check_poly_type rank ubx_tup ty `thenM_` + + traceTc (text "checkValidType done" <+> ppr ty) \end{code} @@ -665,7 +643,7 @@ check_tau_type :: Rank -> UbxTupFlag -> Type -> TcM () -- No foralls otherwise check_tau_type rank ubx_tup ty@(ForAllTy _ _) = failWithTc (forAllTyErr ty) -check_tau_type rank ubx_tup (SourceTy sty) = getDOpts `thenM` \ dflags -> +check_tau_type rank ubx_tup (PredTy sty) = getDOpts `thenM` \ dflags -> check_source_ty dflags TypeCtxt sty check_tau_type rank ubx_tup (TyVarTy _) = returnM () check_tau_type rank ubx_tup ty@(FunTy arg_ty res_ty) @@ -701,6 +679,9 @@ check_tau_type rank ubx_tup (NoteTy (SynNote syn) ty) check_tau_type rank ubx_tup (NoteTy other_note ty) = check_tau_type rank ubx_tup ty +check_tau_type rank ubx_tup (NewTcApp tc tys) + = mappM_ check_arg_type tys + check_tau_type rank ubx_tup ty@(TyConApp tc tys) | isSynTyCon tc = -- NB: Type.mkSynTy builds a TyConApp (not a NoteTy) for an unsaturated @@ -734,9 +715,9 @@ check_tau_type rank ubx_tup ty@(TyConApp tc tys) ubx_tup_msg = ubxArgTyErr ty ---------------------------------------- -forAllTyErr ty = ptext SLIT("Illegal polymorphic type:") <+> ppr_ty ty -unliftedArgErr ty = ptext SLIT("Illegal unlifted type argument:") <+> ppr_ty ty -ubxArgTyErr ty = ptext SLIT("Illegal unboxed tuple type as function argument:") <+> ppr_ty ty +forAllTyErr ty = ptext SLIT("Illegal polymorphic type:") <+> ppr ty +unliftedArgErr ty = ptext SLIT("Illegal unlifted type argument:") <+> ppr ty +ubxArgTyErr ty = ptext SLIT("Illegal unboxed tuple type as function argument:") <+> ppr ty kindErr kind = ptext SLIT("Expecting an ordinary type, but found a type of kind") <+> ppr kind \end{code} @@ -789,7 +770,7 @@ check_valid_theta ctxt theta = getDOpts `thenM` \ dflags -> warnTc (notNull dups) (dupPredWarn dups) `thenM_` -- Actually, in instance decls and type signatures, - -- duplicate constraints are eliminated by TcMonoType.hoistForAllTys, + -- duplicate constraints are eliminated by TcHsType.hoistForAllTys, -- so this error can only fire for the context of a class or -- data type decl. mappM_ (check_source_ty dflags ctxt) theta @@ -799,8 +780,10 @@ check_valid_theta ctxt theta ------------------------- check_source_ty dflags ctxt pred@(ClassP cls tys) = -- Class predicates are valid in all contexts - mappM_ check_arg_type tys `thenM_` checkTc (arity == n_tys) arity_err `thenM_` + + -- Check the form of the argument types + mappM_ check_arg_type tys `thenM_` checkTc (check_class_pred_tys dflags ctxt tys) (predTyVarErr pred $$ how_to_allow) @@ -825,8 +808,6 @@ check_source_ty dflags SigmaCtxt (IParam _ ty) = check_arg_type ty -- constraint Foo [Int] might come out of e,and applying the -- instance decl would show up two uses of ?x. -check_source_ty dflags TypeCtxt (NType tc tys) = mappM_ check_arg_type tys - -- Catch-all check_source_ty dflags ctxt sty = failWithTc (badSourceTyErr sty) @@ -931,7 +912,7 @@ checkThetaCtxt ctxt theta = vcat [ptext SLIT("In the context:") <+> pprTheta theta, ptext SLIT("While checking") <+> pprSourceTyCtxt ctxt ] -badSourceTyErr sty = ptext SLIT("Illegal constraint") <+> pprSourceType sty +badSourceTyErr sty = ptext SLIT("Illegal constraint") <+> pprPred sty predTyVarErr pred = ptext SLIT("Non-type variables in constraint:") <+> pprPred pred dupPredWarn dups = ptext SLIT("Duplicate constraint(s):") <+> pprWithCommas pprPred (map head dups) @@ -947,133 +928,6 @@ arityErr kind name n m %************************************************************************ %* * -\subsection{Validity check for TyCons} -%* * -%************************************************************************ - -checkValidTyCon is called once the mutually-recursive knot has been -tied, so we can look at things freely. - -\begin{code} -checkValidTyCon :: TyCon -> TcM () -checkValidTyCon tc - | isSynTyCon tc = checkValidType (TySynCtxt name) syn_rhs - | otherwise - = -- Check the context on the data decl - checkValidTheta (DataTyCtxt name) (tyConTheta tc) `thenM_` - - -- Check arg types of data constructors - mappM_ checkValidDataCon data_cons `thenM_` - - -- Check that fields with the same name share a type - mappM_ check_fields groups - - where - name = tyConName tc - (_, syn_rhs) = getSynTyConDefn tc - data_cons = tyConDataCons tc - - fields = [field | con <- data_cons, field <- dataConFieldLabels con] - groups = equivClasses cmp_name fields - cmp_name field1 field2 = fieldLabelName field1 `compare` fieldLabelName field2 - - check_fields fields@(first_field_label : other_fields) - -- These fields all have the same name, but are from - -- different constructors in the data type - = -- Check that all the fields in the group have the same type - -- NB: this check assumes that all the constructors of a given - -- data type use the same type variables - checkTc (all (tcEqType field_ty) other_tys) (fieldTypeMisMatch field_name) - where - field_ty = fieldLabelType first_field_label - field_name = fieldLabelName first_field_label - other_tys = map fieldLabelType other_fields - -checkValidDataCon :: DataCon -> TcM () -checkValidDataCon con - = checkValidType ctxt (idType (dataConWrapId con)) `thenM_` - -- This checks the argument types and - -- ambiguity of the existential context (if any) - addErrCtxt (existentialCtxt con) - (checkFreeness ex_tvs ex_theta) - where - ctxt = ConArgCtxt (dataConName con) - (_, _, ex_tvs, ex_theta, _, _) = dataConSig con - - -fieldTypeMisMatch field_name - = sep [ptext SLIT("Different constructors give different types for field"), quotes (ppr field_name)] - -existentialCtxt con = ptext SLIT("When checking the existential context of constructor") - <+> quotes (ppr con) -\end{code} - - -checkValidClass is called once the mutually-recursive knot has been -tied, so we can look at things freely. - -\begin{code} -checkValidClass :: Class -> TcM () -checkValidClass cls - = -- CHECK ARITY 1 FOR HASKELL 1.4 - doptM Opt_GlasgowExts `thenM` \ gla_exts -> - - -- Check that the class is unary, unless GlaExs - checkTc (notNull tyvars) (nullaryClassErr cls) `thenM_` - checkTc (gla_exts || unary) (classArityErr cls) `thenM_` - - -- Check the super-classes - checkValidTheta (ClassSCCtxt (className cls)) theta `thenM_` - - -- Check the class operations - mappM_ check_op op_stuff `thenM_` - - -- Check that if the class has generic methods, then the - -- class has only one parameter. We can't do generic - -- multi-parameter type classes! - checkTc (unary || no_generics) (genericMultiParamErr cls) - - where - (tyvars, theta, _, op_stuff) = classBigSig cls - unary = isSingleton tyvars - no_generics = null [() | (_, GenDefMeth) <- op_stuff] - - check_op (sel_id, dm) - = checkValidTheta SigmaCtxt (tail theta) `thenM_` - -- The 'tail' removes the initial (C a) from the - -- class itself, leaving just the method type - - checkValidType (FunSigCtxt op_name) tau `thenM_` - - -- Check that for a generic method, the type of - -- the method is sufficiently simple - checkTc (dm /= GenDefMeth || validGenericMethodType op_ty) - (badGenericMethodType op_name op_ty) - where - op_name = idName sel_id - op_ty = idType sel_id - (_,theta,tau) = tcSplitSigmaTy op_ty - -nullaryClassErr cls - = ptext SLIT("No parameters for class") <+> quotes (ppr cls) - -classArityErr cls - = vcat [ptext SLIT("Too many parameters for class") <+> quotes (ppr cls), - parens (ptext SLIT("Use -fglasgow-exts to allow multi-parameter classes"))] - -genericMultiParamErr clas - = ptext SLIT("The multi-parameter class") <+> quotes (ppr clas) <+> - ptext SLIT("cannot have generic methods") - -badGenericMethodType op op_ty - = hang (ptext SLIT("Generic method type is too complex")) - 4 (vcat [ppr op <+> dcolon <+> ppr op_ty, - ptext SLIT("You can only use type variables, arrows, and tuples")]) -\end{code} - - -%************************************************************************ -%* * \subsection{Checking for a decent instance head type} %* * %************************************************************************ diff --git a/ghc/compiler/typecheck/TcMatches.lhs b/ghc/compiler/typecheck/TcMatches.lhs index 1a19b03aa6..21c74dcce4 100644 --- a/ghc/compiler/typecheck/TcMatches.lhs +++ b/ghc/compiler/typecheck/TcMatches.lhs @@ -20,22 +20,22 @@ import HsSyn ( HsExpr(..), HsBinds(..), Match(..), GRHSs(..), GRHS(..), ReboundNames, pprMatch, getMatchLoc, isDoExpr, pprMatchContext, pprStmtContext, pprStmtResultContext, - mkMonoBind, collectSigTysFromPats, andMonoBindList, glueBindsOnGRHSs + mkMonoBind, collectSigTysFromPats, glueBindsOnGRHSs ) import RnHsSyn ( RenamedMatch, RenamedGRHSs, RenamedStmt, RenamedHsExpr, RenamedPat, RenamedMatchContext ) import TcHsSyn ( TcMatch, TcGRHSs, TcStmt, TcDictBinds, TcHsBinds, TcExpr, - TcMonoBinds, TcPat, TcStmt, ExprCoFn, + TcPat, TcStmt, ExprCoFn, isIdCoercion, (<$>), (<.>) ) import TcRnMonad -import TcMonoType ( tcAddScopedTyVars, tcHsSigType, UserTypeCtxt(..) ) +import TcHsType ( tcAddScopedTyVars, tcHsSigType, UserTypeCtxt(..) ) import Inst ( tcSyntaxName, tcInstCall ) import TcEnv ( TcId, tcLookupLocalIds, tcLookupId, tcExtendLocalValEnv, tcExtendLocalValEnv2 ) import TcPat ( tcPat, tcMonoPatBndr ) import TcMType ( newTyVarTy, newTyVarTys, zonkTcType ) import TcType ( TcType, TcTyVar, TcSigmaType, TcRhoType, - tyVarsOfTypes, tidyOpenTypes, tidyOpenType, isSigmaTy, + tyVarsOfTypes, tidyOpenTypes, isSigmaTy, mkFunTy, isOverloadedTy, liftedTypeKind, openTypeKind, mkArrowKind, mkAppTy ) import TcBinds ( tcBindsAndThen ) @@ -44,15 +44,13 @@ import TcUnify ( Expected(..), newHole, zapExpectedType, zapExpectedBranches, r checkSigTyVarsWrt, tcSubExp, tcGen ) import TcSimplify ( tcSimplifyCheck, bindInstsOfLocalFuns ) import Name ( Name ) -import PrelNames ( monadNames, mfixName ) import TysWiredIn ( boolTy, mkListTy, mkPArrTy ) -import Id ( idType, mkSysLocal, mkLocalId ) +import Id ( idType, mkLocalId ) import CoreFVs ( idFreeTyVars ) import BasicTypes ( RecFlag(..) ) import VarSet -import Var ( Id ) import Bag -import Util ( isSingleton, notNull, zipEqual ) +import Util ( isSingleton, notNull ) import Outputable import List ( nub ) @@ -146,9 +144,11 @@ tcGRHSsPat grhss exp_ty = tcGRHSs match_ctxt grhss exp_ty \end{code} \begin{code} -data TcMatchCtxt - = MC { mc_what :: RenamedMatchContext, -- What kind of thing this is - mc_body :: RenamedHsExpr -> Expected TcRhoType -> TcM TcExpr } -- Type checker for a body of an alternative +data TcMatchCtxt -- c.f. TcStmtCtxt, also in this module + = MC { mc_what :: RenamedMatchContext, -- What kind of thing this is + mc_body :: RenamedHsExpr -- Type checker for a body of an alternative + -> Expected TcRhoType + -> TcM TcExpr } tcMatches :: TcMatchCtxt -> [RenamedMatch] @@ -481,7 +481,7 @@ tcStmts ctxt stmts tcStmtsAndThen (:) ctxt stmts (returnM []) data TcStmtCtxt - = SC { sc_what :: HsStmtContext Name, -- What kind of thing this is + = SC { sc_what :: HsStmtContext Name, -- What kind of thing this is sc_rhs :: RenamedHsExpr -> TcType -> TcM TcExpr, -- Type checker for RHS computations sc_body :: RenamedHsExpr -> TcM TcExpr, -- Type checker for return computation sc_ty :: TcType } -- Return type; used *only* to check @@ -634,8 +634,8 @@ sigPatCtxt bound_tvs bound_ids tys tidy_env = -- tys is (body_ty : pat_tys) mapM zonkTcType tys `thenM` \ tys' -> let - (env1, tidy_tys) = tidyOpenTypes tidy_env (map idType show_ids) - (env2, tidy_body_ty : tidy_pat_tys) = tidyOpenTypes env1 tys' + (env1, tidy_tys) = tidyOpenTypes tidy_env (map idType show_ids) + (_env2, tidy_body_ty : tidy_pat_tys) = tidyOpenTypes env1 tys' in returnM (env1, sep [ptext SLIT("When checking an existential match that binds"), diff --git a/ghc/compiler/typecheck/TcMonoType.lhs b/ghc/compiler/typecheck/TcMonoType.lhs deleted file mode 100644 index c257251ee0..0000000000 --- a/ghc/compiler/typecheck/TcMonoType.lhs +++ /dev/null @@ -1,772 +0,0 @@ -% -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 -% -\section[TcMonoType]{Typechecking user-specified @MonoTypes@} - -\begin{code} -module TcMonoType ( tcHsSigType, tcHsType, tcIfaceType, tcHsTheta, tcHsPred, - UserTypeCtxt(..), - - -- Kind checking - kcHsTyVar, kcHsTyVars, mkTyClTyVars, - kcHsType, kcHsSigType, kcHsSigTypes, - kcHsLiftedSigType, kcHsContext, - tcAddScopedTyVars, tcHsTyVars, mkImmutTyVars, - - TcSigInfo(..), tcTySig, mkTcSig, maybeSig, tcSigPolyId, tcSigMonoId - ) where - -#include "HsVersions.h" - -import HsSyn ( HsType(..), HsTyVarBndr(..), HsTyOp(..), - Sig(..), HsPred(..), HsTupCon(..), hsTyVarNames ) -import RnHsSyn ( RenamedHsType, RenamedHsPred, RenamedContext, RenamedSig, extractHsTyVars ) -import TcHsSyn ( TcId ) - -import TcRnMonad -import TcEnv ( tcExtendTyVarEnv, tcLookup, tcLookupGlobal, - TyThing(..), TcTyThing(..), tcExtendKindEnv, - getInLocalScope - ) -import TcMType ( newMutTyVar, newKindVar, zonkKindEnv, tcInstType, zonkTcType, - checkValidType, UserTypeCtxt(..), pprUserTypeCtxt, newOpenTypeKind - ) -import TcUnify ( unifyKind, unifyFunKind ) -import TcType ( Type, Kind, SourceType(..), ThetaType, TyVarDetails(..), - TcTyVar, TcKind, TcThetaType, TcTauType, - mkTyVarTy, mkTyVarTys, mkFunTy, isTypeKind, - zipFunTys, mkForAllTys, mkFunTys, tcEqType, isPredTy, - mkSigmaTy, mkPredTy, mkGenTyConApp, mkTyConApp, mkAppTys, - liftedTypeKind, unliftedTypeKind, eqKind, - tcSplitFunTy_maybe, tcSplitForAllTys - ) -import qualified Type ( splitFunTys ) -import Inst ( Inst, InstOrigin(..), newMethod, instToId ) - -import Id ( mkLocalId, idName, idType ) -import Var ( TyVar, mkTyVar, tyVarKind ) -import ErrUtils ( Message ) -import TyCon ( TyCon, tyConKind ) -import Class ( classTyCon ) -import Name ( Name ) -import NameSet -import Subst ( deShadowTy ) -import TysWiredIn ( mkListTy, mkPArrTy, mkTupleTy, genUnitTyCon ) -import BasicTypes ( Boxity(..) ) -import SrcLoc ( SrcLoc ) -import Util ( lengthIs ) -import Outputable -import List ( nubBy ) -\end{code} - - -%************************************************************************ -%* * -\subsection{Checking types} -%* * -%************************************************************************ - -Generally speaking we now type-check types in three phases - - 1. Kind check the HsType [kcHsType] - 2. Convert from HsType to Type, and hoist the foralls [tcHsType] - 3. Check the validity of the resulting type [checkValidType] - -Often these steps are done one after the othe (tcHsSigType). -But in mutually recursive groups of type and class decls we do - 1 kind-check the whole group - 2 build TyCons/Classes in a knot-tied wa - 3 check the validity of types in the now-unknotted TyCons/Classes - -\begin{code} -tcHsSigType :: UserTypeCtxt -> RenamedHsType -> TcM Type - -- Do kind checking, and hoist for-alls to the top -tcHsSigType ctxt ty = addErrCtxt (checkTypeCtxt ctxt ty) ( - kcTypeType ty `thenM_` - tcHsType ty - ) `thenM` \ ty' -> - checkValidType ctxt ty' `thenM_` - returnM ty' - -checkTypeCtxt ctxt ty - = vcat [ptext SLIT("In the type:") <+> ppr ty, - ptext SLIT("While checking") <+> pprUserTypeCtxt ctxt ] - -tcHsType :: RenamedHsType -> TcM Type - -- Don't do kind checking, nor validity checking, - -- but do hoist for-alls to the top - -- This is used in type and class decls, where kinding is - -- done in advance, and validity checking is done later - -- [Validity checking done later because of knot-tying issues.] -tcHsType ty = tc_type ty `thenM` \ ty' -> - returnM (hoistForAllTys ty') - -tcHsTheta :: RenamedContext -> TcM ThetaType --- Used when we are expecting a ClassContext (i.e. no implicit params) --- Does not do validity checking, like tcHsType -tcHsTheta hs_theta = mappM tc_pred hs_theta - --- In interface files the type is already kinded, --- and we definitely don't want to hoist for-alls. --- Otherwise we'll change --- dmfail :: forall m:(*->*) Monad m => forall a:* => String -> m a --- into --- dmfail :: forall m:(*->*) a:* Monad m => String -> m a --- which definitely isn't right! -tcIfaceType ty = tc_type ty -\end{code} - - -%************************************************************************ -%* * -\subsection{Kind checking} -%* * -%************************************************************************ - -Kind checking -~~~~~~~~~~~~~ -When we come across the binding site for some type variables, we -proceed in two stages - -1. Figure out what kind each tyvar has - -2. Create suitably-kinded tyvars, - extend the envt, - and typecheck the body - -To do step 1, we proceed thus: - -1a. Bind each type variable to a kind variable -1b. Apply the kind checker -1c. Zonk the resulting kinds - -The kind checker is passed to tcHsTyVars as an argument. - -For example, when we find - (forall a m. m a -> m a) -we bind a,m to kind varibles and kind-check (m a -> m a). This -makes a get kind *, and m get kind *->*. Now we typecheck (m a -> m a) -in an environment that binds a and m suitably. - -The kind checker passed to tcHsTyVars needs to look at enough to -establish the kind of the tyvar: - * For a group of type and class decls, it's just the group, not - the rest of the program - * For a tyvar bound in a pattern type signature, its the types - mentioned in the other type signatures in that bunch of patterns - * For a tyvar bound in a RULE, it's the type signatures on other - universally quantified variables in the rule - -Note that this may occasionally give surprising results. For example: - - data T a b = MkT (a b) - -Here we deduce a::*->*, b::*. -But equally valid would be - a::(*->*)-> *, b::*->* - -\begin{code} --- tcHsTyVars is used for type variables in type signatures --- e.g. forall a. a->a --- They are immutable, because they scope only over the signature --- They may or may not be explicitly-kinded -tcHsTyVars :: [HsTyVarBndr Name] - -> TcM a -- The kind checker - -> ([TyVar] -> TcM b) - -> TcM b - -tcHsTyVars [] kind_check thing_inside = thing_inside [] - -- A useful short cut for a common case! - -tcHsTyVars tv_names kind_check thing_inside - = kcHsTyVars tv_names `thenM` \ tv_names_w_kinds -> - tcExtendKindEnv tv_names_w_kinds kind_check `thenM_` - zonkKindEnv tv_names_w_kinds `thenM` \ tvs_w_kinds -> - let - tyvars = mkImmutTyVars tvs_w_kinds - in - tcExtendTyVarEnv tyvars (thing_inside tyvars) - - - -tcAddScopedTyVars :: [RenamedHsType] -> TcM a -> TcM a --- tcAddScopedTyVars is used for scoped type variables --- added by pattern type signatures --- e.g. \ (x::a) (y::a) -> x+y --- They never have explicit kinds (because this is source-code only) --- They are mutable (because they can get bound to a more specific type) - --- Find the not-already-in-scope signature type variables, --- kind-check them, and bring them into scope --- --- We no longer specify that these type variables must be univerally --- quantified (lots of email on the subject). If you want to put that --- back in, you need to --- a) Do a checkSigTyVars after thing_inside --- b) More insidiously, don't pass in expected_ty, else --- we unify with it too early and checkSigTyVars barfs --- Instead you have to pass in a fresh ty var, and unify --- it with expected_ty afterwards -tcAddScopedTyVars [] thing_inside - = thing_inside -- Quick get-out for the empty case - -tcAddScopedTyVars sig_tys thing_inside - = getInLocalScope `thenM` \ in_scope -> - let - all_sig_tvs = foldr (unionNameSets . extractHsTyVars) emptyNameSet sig_tys - sig_tvs = filter (not . in_scope) (nameSetToList all_sig_tvs) - in - mappM newNamedKindVar sig_tvs `thenM` \ kind_env -> - tcExtendKindEnv kind_env (kcHsSigTypes sig_tys) `thenM_` - zonkKindEnv kind_env `thenM` \ tvs_w_kinds -> - sequenceM [ newMutTyVar name kind PatSigTv - | (name, kind) <- tvs_w_kinds] `thenM` \ tyvars -> - tcExtendTyVarEnv tyvars thing_inside -\end{code} - - -\begin{code} -kcHsTyVar :: HsTyVarBndr name -> TcM (name, TcKind) -kcHsTyVars :: [HsTyVarBndr name] -> TcM [(name, TcKind)] - -kcHsTyVar (UserTyVar name) = newNamedKindVar name -kcHsTyVar (IfaceTyVar name kind) = returnM (name, kind) - -kcHsTyVars tvs = mappM kcHsTyVar tvs - -newNamedKindVar name = newKindVar `thenM` \ kind -> - returnM (name, kind) - ---------------------------- -kcLiftedType :: RenamedHsType -> TcM Kind - -- The type ty must be a *lifted* *type* -kcLiftedType ty = kcHsType ty `thenM` \ act_kind -> - checkExpectedKind (ppr ty) act_kind liftedTypeKind - ---------------------------- -kcTypeType :: RenamedHsType -> TcM () - -- The type ty must be a *type*, but it can be lifted or unlifted. -kcTypeType ty - = kcHsType ty `thenM` \ kind -> - if isTypeKind kind then - return () - else - newOpenTypeKind `thenM` \ exp_kind -> - checkExpectedKind (ppr ty) kind exp_kind `thenM_` - returnM () - ---------------------------- -kcHsSigType, kcHsLiftedSigType :: RenamedHsType -> TcM () - -- Used for type signatures -kcHsSigType ty = kcTypeType ty -kcHsSigTypes tys = mappM_ kcHsSigType tys -kcHsLiftedSigType ty = kcLiftedType ty `thenM_` returnM () - ---------------------------- -kcHsType :: RenamedHsType -> TcM TcKind --- kcHsType *returns* the kind of the type, rather than taking an expected --- kind as argument as tcExpr does. Reason: the kind of (->) is --- forall bx1 bx2. Type bx1 -> Type bx2 -> Type Boxed --- so we'd need to generate huge numbers of bx variables. - -kcHsType (HsTyVar name) = kcTyVar name -kcHsType (HsListTy ty) = kcLiftedType ty -kcHsType (HsPArrTy ty) = kcLiftedType ty -kcHsType (HsParTy ty) = kcHsType ty -- Skip parentheses markers -kcHsType (HsNumTy _) = returnM liftedTypeKind -- The unit type for generics -kcHsType (HsKindSig ty k) = kcHsType ty `thenM` \ act_kind -> - checkExpectedKind (ppr ty) act_kind k - -kcHsType (HsTupleTy (HsTupCon boxity _) tys) - = mappM kcTypeType tys `thenM_` - returnM (case boxity of - Boxed -> liftedTypeKind - Unboxed -> unliftedTypeKind) - -kcHsType (HsFunTy ty1 ty2) - = kcTypeType ty1 `thenM_` - kcTypeType ty2 `thenM_` - returnM liftedTypeKind - -kcHsType (HsOpTy ty1 HsArrow ty2) - = kcTypeType ty1 `thenM_` - kcTypeType ty2 `thenM_` - returnM liftedTypeKind - -kcHsType ty@(HsOpTy ty1 op_ty@(HsTyOp op) ty2) - = addErrCtxt (appKindCtxt (ppr ty)) $ - kcTyVar op `thenM` \ op_kind -> - kcApps (ppr op_ty) op_kind [ty1,ty2] - -kcHsType (HsPredTy pred) - = kcHsPred pred `thenM_` - returnM liftedTypeKind - -kcHsType ty@(HsAppTy ty1 ty2) - = addErrCtxt (appKindCtxt (ppr ty)) $ - kc_app ty [] - where - kc_app (HsAppTy f a) as = kc_app f (a:as) - kc_app f as = kcHsType f `thenM` \ fk -> - kcApps (ppr f) fk as - -kcHsType (HsForAllTy (Just tv_names) context ty) - = kcHsTyVars tv_names `thenM` \ kind_env -> - tcExtendKindEnv kind_env $ - kcHsContext context `thenM_` - kcLiftedType ty - -- The body of a forall must be of kind * - -- In principle, I suppose, we could allow unlifted types, - -- but it seems simpler to stick to lifted types for now. - ---------------------------- -kcApps :: SDoc -- The function - -> TcKind -- Function kind - -> [RenamedHsType] -- Arg types - -> TcM TcKind -- Result kind -kcApps pp_fun fun_kind args - = go fun_kind args - where - go fk [] = returnM fk - go fk (ty:tys) = unifyFunKind fk `thenM` \ mb_fk -> - case mb_fk of { - Nothing -> failWithTc too_few_args ; - Just (ak',fk') -> - kcHsType ty `thenM` \ ak -> - checkExpectedKind (ppr ty) ak ak' `thenM_` - go fk' tys } - - too_few_args = ptext SLIT("Kind error:") <+> quotes pp_fun <+> - ptext SLIT("is applied to too many type arguments") - ---------------------------- --- We would like to get a decent error message from --- (a) Under-applied type constructors --- f :: (Maybe, Maybe) --- (b) Over-applied type constructors --- f :: Int x -> Int x --- - -checkExpectedKind :: SDoc -> TcKind -> TcKind -> TcM TcKind --- A fancy wrapper for 'unifyKind', which tries to give --- decent error messages. --- Returns the same kind that it is passed, exp_kind -checkExpectedKind pp_ty act_kind exp_kind - | act_kind `eqKind` exp_kind -- Short cut for a very common case - = returnM exp_kind - | otherwise - = tryTc (unifyKind exp_kind act_kind) `thenM` \ (errs, mb_r) -> - case mb_r of { - Just _ -> returnM exp_kind ; -- Unification succeeded - Nothing -> - - -- So there's definitely an error - -- Now to find out what sort - zonkTcType exp_kind `thenM` \ exp_kind -> - zonkTcType act_kind `thenM` \ act_kind -> - - let (exp_as, _) = Type.splitFunTys exp_kind - (act_as, _) = Type.splitFunTys act_kind - -- Use the Type versions for kinds - n_exp_as = length exp_as - n_act_as = length act_as - - err | n_exp_as < n_act_as -- E.g. [Maybe] - = quotes pp_ty <+> ptext SLIT("is not applied to enough type arguments") - - -- Now n_exp_as >= n_act_as. In the next two cases, - -- n_exp_as == 0, and hence so is n_act_as - | exp_kind `eqKind` liftedTypeKind && act_kind `eqKind` unliftedTypeKind - = ptext SLIT("Expecting a lifted type, but") <+> quotes pp_ty - <+> ptext SLIT("is unlifted") - - | exp_kind `eqKind` unliftedTypeKind && act_kind `eqKind` liftedTypeKind - = ptext SLIT("Expecting an unlifted type, but") <+> quotes pp_ty - <+> ptext SLIT("is lifted") - - | otherwise -- E.g. Monad [Int] - = sep [ ptext SLIT("Expecting kind") <+> quotes (ppr exp_kind) <> comma, - ptext SLIT("but") <+> quotes pp_ty <+> - ptext SLIT("has kind") <+> quotes (ppr act_kind)] - in - failWithTc (ptext SLIT("Kind error:") <+> err) - } - ---------------------------- -kc_pred :: RenamedHsPred -> TcM TcKind -- Does *not* check for a saturated - -- application (reason: used from TcDeriv) -kc_pred pred@(HsIParam name ty) - = kcHsType ty - -kc_pred pred@(HsClassP cls tys) - = kcClass cls `thenM` \ kind -> - kcApps (ppr cls) kind tys - ---------------------------- -kcHsContext ctxt = mappM_ kcHsPred ctxt - -kcHsPred pred -- Checks that the result is of kind liftedType - = addErrCtxt (appKindCtxt (ppr pred)) $ - kc_pred pred `thenM` \ kind -> - checkExpectedKind (ppr pred) kind liftedTypeKind - - - --------------------------- -kcTyVar name -- Could be a tyvar or a tycon - = tcLookup name `thenM` \ thing -> - case thing of - AThing kind -> returnM kind - ATyVar tv -> returnM (tyVarKind tv) - AGlobal (ATyCon tc) -> returnM (tyConKind tc) - other -> failWithTc (wrongThingErr "type" thing name) - -kcClass cls -- Must be a class - = tcLookup cls `thenM` \ thing -> - case thing of - AThing kind -> returnM kind - AGlobal (AClass cls) -> returnM (tyConKind (classTyCon cls)) - other -> failWithTc (wrongThingErr "class" thing cls) -\end{code} - -%************************************************************************ -%* * -\subsection{tc_type} -%* * -%************************************************************************ - -tc_type, the main work horse -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - ------------------- - *** BIG WARNING *** - ------------------- - -tc_type is used to typecheck the types in the RHS of data -constructors. In the case of recursive data types, that means that -the type constructors themselves are (partly) black holes. e.g. - - data T a = MkT a [T a] - -While typechecking the [T a] on the RHS, T itself is not yet fully -defined. That in turn places restrictions on what you can check in -tcHsType; if you poke on too much you get a black hole. I keep -forgetting this, hence this warning! - -So tc_type does no validity-checking. Instead that's all done -by TcMType.checkValidType - - -------------------------- - *** END OF BIG WARNING *** - -------------------------- - - -\begin{code} -tc_type :: RenamedHsType -> TcM Type - -tc_type ty@(HsTyVar name) - = tc_app ty [] - -tc_type (HsKindSig ty k) - = tc_type ty -- Kind checking done already - -tc_type (HsListTy ty) - = tc_type ty `thenM` \ tau_ty -> - returnM (mkListTy tau_ty) - -tc_type (HsPArrTy ty) - = tc_type ty `thenM` \ tau_ty -> - returnM (mkPArrTy tau_ty) - -tc_type (HsTupleTy (HsTupCon boxity arity) tys) - = ASSERT( tys `lengthIs` arity ) - tc_types tys `thenM` \ tau_tys -> - returnM (mkTupleTy boxity arity tau_tys) - -tc_type (HsFunTy ty1 ty2) - = tc_type ty1 `thenM` \ tau_ty1 -> - tc_type ty2 `thenM` \ tau_ty2 -> - returnM (mkFunTy tau_ty1 tau_ty2) - -tc_type (HsOpTy ty1 HsArrow ty2) - = tc_type ty1 `thenM` \ tau_ty1 -> - tc_type ty2 `thenM` \ tau_ty2 -> - returnM (mkFunTy tau_ty1 tau_ty2) - -tc_type (HsOpTy ty1 (HsTyOp op) ty2) - = tc_type ty1 `thenM` \ tau_ty1 -> - tc_type ty2 `thenM` \ tau_ty2 -> - tc_fun_type op [tau_ty1,tau_ty2] - -tc_type (HsParTy ty) -- Remove the parentheses markers - = tc_type ty - -tc_type (HsNumTy n) - = ASSERT(n== 1) - returnM (mkTyConApp genUnitTyCon []) - -tc_type ty@(HsAppTy ty1 ty2) - = addErrCtxt (appKindCtxt (ppr ty)) $ - tc_app ty1 [ty2] - -tc_type (HsPredTy pred) - = tc_pred pred `thenM` \ pred' -> - returnM (mkPredTy pred') - -tc_type full_ty@(HsForAllTy (Just tv_names) ctxt ty) - = let - kind_check = kcHsContext ctxt `thenM_` kcHsType ty - in - tcHsTyVars tv_names kind_check $ \ tyvars -> - mappM tc_pred ctxt `thenM` \ theta -> - tc_type ty `thenM` \ tau -> - returnM (mkSigmaTy tyvars theta tau) - -tc_types arg_tys = mappM tc_type arg_tys -\end{code} - -Help functions for type applications -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -\begin{code} -tc_app :: RenamedHsType -> [RenamedHsType] -> TcM Type -tc_app (HsAppTy ty1 ty2) tys - = tc_app ty1 (ty2:tys) - -tc_app ty tys - = tc_types tys `thenM` \ arg_tys -> - case ty of - HsTyVar fun -> tc_fun_type fun arg_tys - other -> tc_type ty `thenM` \ fun_ty -> - returnM (mkAppTys fun_ty arg_tys) - --- (tc_fun_type ty arg_tys) returns (mkAppTys ty arg_tys) --- But not quite; for synonyms it checks the correct arity, and builds a SynTy --- hence the rather strange functionality. - -tc_fun_type name arg_tys - = tcLookup name `thenM` \ thing -> - case thing of - ATyVar tv -> returnM (mkAppTys (mkTyVarTy tv) arg_tys) - - AGlobal (ATyCon tc) -> returnM (mkGenTyConApp tc arg_tys) - - other -> failWithTc (wrongThingErr "type constructor" thing name) -\end{code} - - -Contexts -~~~~~~~~ -\begin{code} -tcHsPred pred = kc_pred pred `thenM_` tc_pred pred - -- Is happy with a partial application, e.g. (ST s) - -- Used from TcDeriv - -tc_pred assn@(HsClassP class_name tys) - = addErrCtxt (appKindCtxt (ppr assn)) $ - tc_types tys `thenM` \ arg_tys -> - tcLookupGlobal class_name `thenM` \ thing -> - case thing of - AClass clas -> returnM (ClassP clas arg_tys) - other -> failWithTc (wrongThingErr "class" (AGlobal thing) class_name) - -tc_pred assn@(HsIParam name ty) - = addErrCtxt (appKindCtxt (ppr assn)) $ - tc_type ty `thenM` \ arg_ty -> - returnM (IParam name arg_ty) -\end{code} - - - -%************************************************************************ -%* * -\subsection{Type variables, with knot tying!} -%* * -%************************************************************************ - -\begin{code} -mkImmutTyVars :: [(Name,Kind)] -> [TyVar] -mkImmutTyVars pairs = [mkTyVar name kind | (name, kind) <- pairs] - -mkTyClTyVars :: Kind -- Kind of the tycon or class - -> [HsTyVarBndr Name] - -> [TyVar] -mkTyClTyVars kind tyvar_names - = mkImmutTyVars tyvars_w_kinds - where - (tyvars_w_kinds, _) = zipFunTys (hsTyVarNames tyvar_names) kind -\end{code} - - -%************************************************************************ -%* * -\subsection{Signatures} -%* * -%************************************************************************ - -@tcSigs@ checks the signatures for validity, and returns a list of -{\em freshly-instantiated} signatures. That is, the types are already -split up, and have fresh type variables installed. All non-type-signature -"RenamedSigs" are ignored. - -The @TcSigInfo@ contains @TcTypes@ because they are unified with -the variable's type, and after that checked to see whether they've -been instantiated. - -\begin{code} -data TcSigInfo - = TySigInfo - TcId -- *Polymorphic* binder for this value... - -- Has name = N - - [TcTyVar] -- tyvars - TcThetaType -- theta - TcTauType -- tau - - TcId -- *Monomorphic* binder for this value - -- Does *not* have name = N - -- Has type tau - - [Inst] -- Empty if theta is null, or - -- (method mono_id) otherwise - - SrcLoc -- Of the signature - -instance Outputable TcSigInfo where - ppr (TySigInfo id tyvars theta tau _ inst loc) = - ppr id <+> ptext SLIT("::") <+> ppr tyvars <+> ppr theta <+> ptext SLIT("=>") <+> ppr tau - -tcSigPolyId :: TcSigInfo -> TcId -tcSigPolyId (TySigInfo id _ _ _ _ _ _) = id - -tcSigMonoId :: TcSigInfo -> TcId -tcSigMonoId (TySigInfo _ _ _ _ id _ _) = id - -maybeSig :: [TcSigInfo] -> Name -> Maybe (TcSigInfo) - -- Search for a particular signature -maybeSig [] name = Nothing -maybeSig (sig@(TySigInfo sig_id _ _ _ _ _ _) : sigs) name - | name == idName sig_id = Just sig - | otherwise = maybeSig sigs name -\end{code} - - -\begin{code} -tcTySig :: RenamedSig -> TcM TcSigInfo - -tcTySig (Sig v ty src_loc) - = addSrcLoc src_loc $ - tcHsSigType (FunSigCtxt v) ty `thenM` \ sigma_tc_ty -> - mkTcSig (mkLocalId v sigma_tc_ty) `thenM` \ sig -> - returnM sig - -mkTcSig :: TcId -> TcM TcSigInfo -mkTcSig poly_id - = -- Instantiate this type - -- It's important to do this even though in the error-free case - -- we could just split the sigma_tc_ty (since the tyvars don't - -- unified with anything). But in the case of an error, when - -- the tyvars *do* get unified with something, we want to carry on - -- typechecking the rest of the program with the function bound - -- to a pristine type, namely sigma_tc_ty - tcInstType SigTv (idType poly_id) `thenM` \ (tyvars', theta', tau') -> - - getInstLoc SignatureOrigin `thenM` \ inst_loc -> - newMethod inst_loc poly_id - (mkTyVarTys tyvars') - theta' tau' `thenM` \ inst -> - -- We make a Method even if it's not overloaded; no harm - -- But do not extend the LIE! We're just making an Id. - - getSrcLocM `thenM` \ src_loc -> - returnM (TySigInfo poly_id tyvars' theta' tau' - (instToId inst) [inst] src_loc) -\end{code} - - -%************************************************************************ -%* * -\subsection{Errors and contexts} -%* * -%************************************************************************ - - -\begin{code} -hoistForAllTys :: Type -> Type --- Used for user-written type signatures only --- Move all the foralls and constraints to the top --- e.g. T -> forall a. a ==> forall a. T -> a --- T -> (?x::Int) -> Int ==> (?x::Int) -> T -> Int --- --- Also: eliminate duplicate constraints. These can show up --- when hoisting constraints, notably implicit parameters. --- --- We want to 'look through' type synonyms when doing this --- so it's better done on the Type than the HsType - -hoistForAllTys ty - = let - no_shadow_ty = deShadowTy ty - -- Running over ty with an empty substitution gives it the - -- no-shadowing property. This is important. For example: - -- type Foo r = forall a. a -> r - -- foo :: Foo (Foo ()) - -- Here the hoisting should give - -- foo :: forall a a1. a -> a1 -> () - -- - -- What about type vars that are lexically in scope in the envt? - -- We simply rely on them having a different unique to any - -- binder in 'ty'. Otherwise we'd have to slurp the in-scope-tyvars - -- out of the envt, which is boring and (I think) not necessary. - in - case hoist no_shadow_ty of - (tvs, theta, body) -> mkForAllTys tvs (mkFunTys (nubBy tcEqType theta) body) - -- The 'nubBy' eliminates duplicate constraints, - -- notably implicit parameters - where - hoist ty - | (tvs1, body_ty) <- tcSplitForAllTys ty, - not (null tvs1) - = case hoist body_ty of - (tvs2,theta,tau) -> (tvs1 ++ tvs2, theta, tau) - - | Just (arg, res) <- tcSplitFunTy_maybe ty - = let - arg' = hoistForAllTys arg -- Don't forget to apply hoist recursively - in -- to the argument type - if (isPredTy arg') then - case hoist res of - (tvs,theta,tau) -> (tvs, arg':theta, tau) - else - case hoist res of - (tvs,theta,tau) -> (tvs, theta, mkFunTy arg' tau) - - | otherwise = ([], [], ty) -\end{code} - - -%************************************************************************ -%* * -\subsection{Errors and contexts} -%* * -%************************************************************************ - -\begin{code} -typeKindCtxt :: RenamedHsType -> Message -typeKindCtxt ty = sep [ptext SLIT("When checking that"), - nest 2 (quotes (ppr ty)), - ptext SLIT("is a type")] - -appKindCtxt :: SDoc -> Message -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 (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") -\end{code} diff --git a/ghc/compiler/typecheck/TcPat.lhs b/ghc/compiler/typecheck/TcPat.lhs index b0bb16bf9c..8f6840452e 100644 --- a/ghc/compiler/typecheck/TcPat.lhs +++ b/ghc/compiler/typecheck/TcPat.lhs @@ -30,7 +30,7 @@ import TcType ( TcType, TcTyVar, TcSigmaType, mkClassPred, liftedTypeKind ) import TcUnify ( tcSubOff, Expected(..), readExpectedType, zapExpectedType, unifyTauTy, zapToListTy, zapToPArrTy, zapToTupleTy ) -import TcMonoType ( tcHsSigType, UserTypeCtxt(..) ) +import TcHsType ( tcHsSigType, UserTypeCtxt(..) ) import TysWiredIn ( stringTy ) import CmdLineOpts ( opt_IrrefutableTuples ) @@ -271,8 +271,8 @@ tcPat tc_bndr pat@(NPatIn over_lit mb_neg) pat_ty -- But in NPat, the literal is used to find identical patterns -- so we must negate the literal when necessary! lit' = case (over_lit, mb_neg) of - (HsIntegral i _, Nothing) -> HsInteger i - (HsIntegral i _, Just _) -> HsInteger (-i) + (HsIntegral i _, Nothing) -> HsInteger i pat_ty' + (HsIntegral i _, Just _) -> HsInteger (-i) pat_ty' (HsFractional f _, Nothing) -> HsRat f pat_ty' (HsFractional f _, Just _) -> HsRat (-f) pat_ty' in diff --git a/ghc/compiler/typecheck/TcRnDriver.lhs b/ghc/compiler/typecheck/TcRnDriver.lhs index 60d1d95569..20d0d216c6 100644 --- a/ghc/compiler/typecheck/TcRnDriver.lhs +++ b/ghc/compiler/typecheck/TcRnDriver.lhs @@ -6,10 +6,10 @@ \begin{code} module TcRnDriver ( #ifdef GHCI - mkGlobalContext, getModuleContents, tcRnStmt, tcRnThing, tcRnExpr, + mkExportEnv, getModuleContents, tcRnStmt, tcRnThing, tcRnExpr, #endif - tcRnModule, checkOldIface, - importSupportingDecls, tcTopSrcDecls, + tcRnModule, + tcTopSrcDecls, tcRnIface, tcRnExtCore ) where @@ -17,109 +17,103 @@ module TcRnDriver ( #ifdef GHCI import {-# SOURCE #-} TcSplice ( tcSpliceDecls ) -import DsMeta ( templateHaskellNames ) #endif import CmdLineOpts ( DynFlag(..), opt_PprStyle_Debug, dopt ) import DriverState ( v_MainModIs, v_MainFunIs ) import HsSyn ( HsModule(..), HsBinds(..), MonoBinds(..), HsExpr(..), - Stmt(..), Pat(VarPat), HsStmtContext(..), RuleDecl(..), - HsGroup(..), SpliceDecl(..), - mkSimpleMatch, placeHolderType, toHsType, andMonoBinds, - isSrcRule, collectStmtsBinders + HsGroup(..), SpliceDecl(..), HsExtCore(..), + andMonoBinds ) -import RdrHsSyn ( RdrNameHsModule, RdrNameHsDecl, RdrNameStmt, RdrNameHsExpr, - emptyGroup, mkGroup, findSplice, addImpDecls, main_RDR_Unqual ) - -import PrelNames ( iNTERACTIVE, ioTyConName, printName, monadNames, - returnIOName, runIOName, - rootMainName, itName, mAIN_Name - ) -import RdrName ( RdrName, getRdrName, mkRdrUnqual, - lookupRdrEnv, elemRdrEnv ) - -import RnHsSyn ( RenamedStmt, RenamedTyClDecl, - ruleDeclFVs, instDeclFVs, tyClDeclFVs ) -import TcHsSyn ( TypecheckedHsExpr, TypecheckedRuleDecl, - zonkTopDecls, mkHsLet, - zonkTopExpr, zonkTopBndrs - ) - -import TcExpr ( tcInferRho, tcCheckRho ) +import RdrHsSyn ( RdrNameHsModule, RdrNameHsDecl, + findSplice, main_RDR_Unqual ) + +import PrelNames ( runIOName, rootMainName, mAIN_Name ) +import RdrName ( RdrName, mkRdrUnqual, emptyGlobalRdrEnv, + plusGlobalRdrEnv ) +import TcHsSyn ( zonkTopDecls ) +import TcExpr ( tcInferRho ) import TcRnMonad -import TcType ( Type, - tyVarsOfType, tcFunResultTy, tidyTopType, - mkForAllTys, mkFunTys, mkTyConApp, tcSplitForAllTys - ) -import Inst ( showLIE, tcStdSyntaxName ) -import MkId ( unsafeCoerceId ) +import TcType ( tidyTopType ) +import Inst ( showLIE ) import TcBinds ( tcTopBinds ) -import TcClassDcl ( tcClassDecls2 ) import TcDefaults ( tcDefaults ) -import TcEnv ( tcExtendGlobalValEnv, - tcExtendInstEnv, tcExtendRules, - tcLookupTyCon, tcLookupGlobal, - tcLookupId - ) +import TcEnv ( tcExtendGlobalValEnv, tcLookupGlobal ) import TcRules ( tcRules ) import TcForeign ( tcForeignImports, tcForeignExports ) -import TcIfaceSig ( tcInterfaceSigs, tcCoreBinds ) -import TcInstDcls ( tcInstDecls1, tcIfaceInstDecls, tcInstDecls2 ) -import TcSimplify ( tcSimplifyTop, tcSimplifyInteractive, tcSimplifyInfer ) +import TcInstDcls ( tcInstDecls1, tcInstDecls2 ) +import TcIface ( typecheckIface, tcExtCoreBindings ) +import TcSimplify ( tcSimplifyTop ) import TcTyClsDecls ( tcTyAndClassDecls ) - +import LoadIface ( loadOrphanModules ) import RnNames ( importsFromLocalDecls, rnImports, exportsFromAvail, reportUnusedNames ) -import RnIfaces ( slurpImpDecls, checkVersions, RecompileRequired, outOfDate ) -import RnHiFiles ( readIface, loadOldIface ) -import RnEnv ( lookupSrcName, lookupOccRn, plusGlobalRdrEnv, - ubiquitousNames, implicitModuleFVs, implicitStmtFVs, dataTcOccs ) -import RnSource ( rnSrcDecls, checkModDeprec, rnStats ) - -import CoreUnfold ( unfoldingTemplate ) -import CoreSyn ( IdCoreRule, Bind(..) ) +import RnEnv ( lookupSrcOcc_maybe ) +import RnSource ( rnSrcDecls, rnTyClDecls, checkModDeprec ) import PprCore ( pprIdRules, pprCoreBindings ) -import ErrUtils ( mkDumpDoc, showPass, pprBagOfErrors ) -import Id ( Id, mkLocalId, isLocalId, idName, idType, idUnfolding, setIdLocalExported ) -import Var ( Var, setGlobalIdDetails ) -import Module ( Module, mkHomeModule, mkModuleName, moduleName, moduleUserString, moduleEnvElts ) +import CoreSyn ( IdCoreRule, bindersOfBinds ) +import ErrUtils ( mkDumpDoc, showPass ) +import Id ( mkLocalId, isLocalId, idName, idType, setIdLocalExported ) +import Var ( Var ) +import Module ( mkHomeModule, mkModuleName, moduleName, moduleEnvElts ) import OccName ( mkVarOcc ) -import Name ( Name, isExternalName, getSrcLoc, nameOccName ) +import Name ( Name, isExternalName, getSrcLoc, getOccName ) import NameSet -import TyCon ( tyConGenInfo ) -import BasicTypes ( EP(..), RecFlag(..) ) +import TyCon ( tyConHasGenerics ) import Outputable -import HscTypes ( PersistentCompilerState(..), InteractiveContext(..), - ModIface, ModDetails(..), ModGuts(..), - HscEnv(..), - ModIface(..), ModDetails(..), IfaceDecls(..), +import HscTypes ( ModIface, ModDetails(..), ModGuts(..), + HscEnv(..), ModIface(..), ModDetails(..), GhciMode(..), noDependencies, - Deprecations(..), plusDeprecs, - emptyGlobalRdrEnv, - GenAvailInfo(Avail), availsToNameSet, - ForeignStubs(..), - TypeEnv, TyThing, typeEnvTyCons, + Deprecs( NoDeprecs ), plusDeprecs, + GenAvailInfo(Avail), availsToNameSet, availName, + ForeignStubs(NoStubs), TypeEnv, typeEnvTyCons, extendTypeEnvWithIds, typeEnvIds, typeEnvTyCons, - extendLocalRdrEnv, emptyFixityEnv + emptyFixityEnv ) #ifdef GHCI +import HsSyn ( HsStmtContext(..), + Stmt(..), Pat(VarPat), + collectStmtsBinders, mkSimpleMatch, placeHolderType ) +import RdrHsSyn ( RdrNameHsExpr, RdrNameStmt ) +import RdrName ( GlobalRdrEnv, mkGlobalRdrEnv, GlobalRdrElt(..), + Provenance(..), ImportSpec(..), + lookupLocalRdrEnv, extendLocalRdrEnv ) +import RnHsSyn ( RenamedStmt ) +import RnSource ( addTcgDUs ) +import TcHsSyn ( TypecheckedHsExpr, mkHsLet, zonkTopExpr, zonkTopBndrs ) +import TcExpr ( tcCheckRho ) import TcMType ( zonkTcType ) import TcMatches ( tcStmtsAndThen, TcStmtCtxt(..) ) -import RdrName ( rdrEnvElts ) +import TcSimplify ( tcSimplifyInteractive, tcSimplifyInfer ) +import TcType ( Type, mkForAllTys, mkFunTys, mkTyConApp, tyVarsOfType ) +import TcEnv ( tcLookupTyCon, tcLookupId ) +import TyCon ( DataConDetails(..) ) +import Inst ( tcStdSyntaxName ) import RnExpr ( rnStmts, rnExpr ) -import RnHiFiles ( loadInterface ) -import RnEnv ( mkGlobalRdrEnv ) +import RnNames ( exportsToAvails ) +import LoadIface ( loadSysInterface ) +import IfaceSyn ( IfaceDecl(..), IfaceClassOp(..), IfaceConDecl(..), IfaceExtName(..), + tyThingToIfaceDecl ) +import IfaceEnv ( tcIfaceGlobal ) +import RnEnv ( lookupOccRn, dataTcOccs, lookupFixityRn ) +import Id ( Id, isImplicitId ) +import MkId ( unsafeCoerceId ) import TysWiredIn ( mkListTy, unitTy ) import IdInfo ( GlobalIdDetails(..) ) -import SrcLoc ( noSrcLoc ) +import SrcLoc ( interactiveSrcLoc ) +import Var ( setGlobalIdDetails ) +import Name ( nameOccName, nameModuleName ) import NameEnv ( delListFromNameEnv ) -import HscTypes ( GlobalRdrElt(..), GlobalRdrEnv, ImportReason(..), Provenance(..), - isLocalGRE ) +import PrelNames ( iNTERACTIVE, ioTyConName, printName, monadNames, itName, returnIOName ) +import Module ( ModuleName, lookupModuleEnvByName ) +import HscTypes ( InteractiveContext(..), + HomeModInfo(..), typeEnvElts, + TyThing(..), availNames, icPrintUnqual ) +import BasicTypes ( RecFlag(..), Fixity ) +import Panic ( ghcError, GhcException(..) ) #endif import FastString ( mkFastString ) -import Panic ( showException ) -import List ( partition ) import Util ( sortLt ) \end{code} @@ -133,11 +127,11 @@ import Util ( sortLt ) \begin{code} -tcRnModule :: HscEnv -> PersistentCompilerState +tcRnModule :: HscEnv -> RdrNameHsModule - -> IO (PersistentCompilerState, Maybe TcGblEnv) + -> IO (Maybe TcGblEnv) -tcRnModule hsc_env pcs +tcRnModule hsc_env (HsModule maybe_mod exports import_decls local_decls mod_deprec loc) = do { showPass (hsc_dflags hsc_env) "Renamer/typechecker" ; @@ -145,7 +139,7 @@ tcRnModule hsc_env pcs Nothing -> mkHomeModule mAIN_Name -- 'module M where' is omitted Just mod -> mod } ; -- The normal case - initTc hsc_env pcs this_mod $ addSrcLoc loc $ + initTc hsc_env this_mod $ addSrcLoc loc $ do { -- Deal with imports; sets tcg_rdr_env, tcg_imports (rdr_env, imports) <- rnImports import_decls ; updGblEnv ( \ gbl -> gbl { tcg_rdr_env = rdr_env, @@ -157,24 +151,19 @@ tcRnModule hsc_env pcs -- of the tcg_env we have now set failIfErrsM ; + -- Load any orphan-module interfaces, so that + -- their rules and instance decls will be found + loadOrphanModules (imp_orphs imports) ; + traceRn (text "rn1a") ; -- Rename and type check the declarations - (tcg_env, src_dus) <- tcRnSrcDecls local_decls ; + tcg_env <- tcRnSrcDecls local_decls ; setGblEnv tcg_env $ do { traceRn (text "rn3") ; - -- Check whether the entire module is deprecated - -- This happens only once per module - -- Returns the full new deprecations; a module deprecation - -- over-rides the earlier ones - let { mod_deprecs = checkModDeprec mod_deprec } ; - updGblEnv (\gbl -> gbl { tcg_deprecs = tcg_deprecs gbl `plusDeprecs` mod_deprecs }) - $ do { -- Process the export list export_avails <- exportsFromAvail maybe_mod exports ; - updGblEnv (\gbl -> gbl { tcg_exports = export_avails }) - $ do { -- Get any supporting decls for the exports that have not already -- been sucked in for the declarations in the body of the module. @@ -183,21 +172,30 @@ tcRnModule hsc_env pcs -- Importing these supporting declarations is required -- *only* to gether usage information -- (see comments with MkIface.mkImportInfo for why) - -- For OneShot compilation we could just throw away the decls - -- but for Batch or Interactive we must put them in the type - -- envt because they've been removed from the holding pen - let { export_fvs = availsToNameSet export_avails } ; - tcg_env <- importSupportingDecls export_fvs ; - setGblEnv tcg_env $ do { + -- We don't need the results, but sucking them in may side-effect + -- the ExternalPackageState, apart from recording usage + mappM (tcLookupGlobal . availName) export_avails ; + + -- Check whether the entire module is deprecated + -- This happens only once per module + let { mod_deprecs = checkModDeprec mod_deprec } ; + + -- Add exports and deprecations to envt + let { export_fvs = availsToNameSet export_avails ; + final_env = tcg_env { tcg_exports = export_avails, + tcg_dus = tcg_dus tcg_env `plusDU` usesOnly export_fvs, + tcg_deprecs = tcg_deprecs tcg_env `plusDeprecs` + mod_deprecs } + -- A module deprecation over-rides the earlier ones + } ; -- Report unused names - let { all_dus = src_dus `plusDU` usesOnly export_fvs } ; - reportUnusedNames tcg_env all_dus ; + reportUnusedNames final_env ; -- Dump output and return - tcDump tcg_env ; - return tcg_env - }}}}}}} + tcDump final_env ; + return final_env + }}}} \end{code} @@ -212,42 +210,10 @@ IfaceDecls in the ModIface, and fluff them up by sucking in all the decls they n \begin{code} tcRnIface :: HscEnv - -> PersistentCompilerState -> ModIface -- Get the decls from here - -> IO (PersistentCompilerState, Maybe ModDetails) - -- Nothing <=> errors happened -tcRnIface hsc_env pcs - (ModIface {mi_module = mod, mi_decls = iface_decls}) - = initTc hsc_env pcs mod $ do { - - -- Get the supporting decls, and typecheck them all together - -- so that any mutually recursive types are done right - extra_decls <- slurpImpDecls needed ; - env <- typecheckIfaceDecls (group `addImpDecls` extra_decls) ; - - returnM (ModDetails { md_types = tcg_type_env env, - md_insts = tcg_insts env, - md_rules = hsCoreRules (tcg_rules env) - -- All the rules from an interface are of the IfaceRuleOut form - }) } - where - rule_decls = dcl_rules iface_decls - inst_decls = dcl_insts iface_decls - tycl_decls = dcl_tycl iface_decls - group = emptyGroup { hs_ruleds = rule_decls, - hs_instds = inst_decls, - hs_tyclds = tycl_decls } - needed = unionManyNameSets (map ruleDeclFVs rule_decls) `unionNameSets` - unionManyNameSets (map instDeclFVs inst_decls) `unionNameSets` - unionManyNameSets (map tyClDeclFVs tycl_decls) `unionNameSets` - ubiquitousNames - -- Data type decls with record selectors, - -- which may appear in the decls, need unpackCString - -- and friends. It's easier to just grab them right now. - -hsCoreRules :: [TypecheckedRuleDecl] -> [IdCoreRule] --- All post-typechecking Iface rules have the form IfaceRuleOut -hsCoreRules rules = [(id,rule) | IfaceRuleOut id rule <- rules] + -> IO ModDetails +tcRnIface hsc_env iface + = initIfaceIO hsc_env (typecheckIface iface) \end{code} @@ -259,41 +225,25 @@ hsCoreRules rules = [(id,rule) | IfaceRuleOut id rule <- rules] \begin{code} #ifdef GHCI -tcRnStmt :: HscEnv -> PersistentCompilerState +tcRnStmt :: HscEnv -> InteractiveContext -> RdrNameStmt - -> IO (PersistentCompilerState, - Maybe (InteractiveContext, [Name], TypecheckedHsExpr)) + -> IO (Maybe (InteractiveContext, [Name], TypecheckedHsExpr)) -- The returned [Name] is the same as the input except for -- ExprStmt, in which case the returned [Name] is [itName] -- -- The returned TypecheckedHsExpr is of type IO [ () ], -- a list of the bound values, coerced to (). -tcRnStmt hsc_env pcs ictxt rdr_stmt - = initTc hsc_env pcs iNTERACTIVE $ +tcRnStmt hsc_env ictxt rdr_stmt + = initTc hsc_env iNTERACTIVE $ setInteractiveContext ictxt $ do { -- Rename; use CmdLineMode because tcRnStmt is only used interactively - ([rn_stmt], fvs) <- initRnInteractive ictxt - (rnStmts DoExpr [rdr_stmt]) ; + ([rn_stmt], fvs) <- rnStmts DoExpr [rdr_stmt] ; traceRn (text "tcRnStmt" <+> vcat [ppr rdr_stmt, ppr rn_stmt, ppr fvs]) ; failIfErrsM ; - -- Suck in the supporting declarations and typecheck them - tcg_env <- importSupportingDecls (fvs `plusFV` implicitStmtFVs fvs) ; - -- NB: an earlier version deleted (rdrEnvElts local_env) from - -- the fvs. But (a) that isn't necessary, because previously - -- bound things in the local_env will be in the TypeEnv, and - -- the renamer doesn't re-slurp such things, and - -- (b) it's WRONG to delete them. Consider in GHCi: - -- Mod> let x = e :: T - -- Mod> let y = x + 3 - -- We need to pass 'x' among the fvs to slurpImpDecls, so that - -- the latter can see that T is a gate, and hence import the Num T - -- instance decl. (See the InTypEnv case in RnIfaces.slurpSourceRefs.) - setGblEnv tcg_env $ do { - -- The real work is done here (bound_ids, tc_expr) <- tcUserStmt rn_stmt ; @@ -318,7 +268,7 @@ tcRnStmt hsc_env pcs ictxt rdr_stmt -- a space leak if we leave them there shadowed = [ n | name <- bound_names, let rdr_name = mkRdrUnqual (nameOccName name), - Just n <- [lookupRdrEnv rn_env rdr_name] ] ; + Just n <- [lookupLocalRdrEnv rn_env rdr_name] ] ; filtered_type_env = delListFromNameEnv type_env shadowed ; new_type_env = extendTypeEnvWithIds filtered_type_env global_ids ; @@ -332,7 +282,7 @@ tcRnStmt hsc_env pcs ictxt rdr_stmt text "Typechecked expr" <+> ppr tc_expr]) ; returnM (new_ic, bound_names, tc_expr) - }} + } \end{code} @@ -423,10 +373,10 @@ tc_stmts stmts -- where they will all be in scope ids <- mappM tcLookupId names ; ret_id <- tcLookupId returnIOName ; -- return @ IO - return (ids, [ResultStmt (mk_return ret_id ids) noSrcLoc]) } ; + return (ids, [ResultStmt (mk_return ret_id ids) interactiveSrcLoc]) } ; io_ids <- mappM (tcStdSyntaxName DoOrigin io_ty) monadNames ; - return (ids, HsDo DoExpr tc_stmts io_ids io_ret_ty noSrcLoc) + return (ids, HsDo DoExpr tc_stmts io_ids io_ret_ty interactiveSrcLoc) } ; -- Simplify the context right here, so that we fail @@ -453,21 +403,17 @@ tc_stmts stmts tcRnExpr just finds the type of an expression \begin{code} -tcRnExpr :: HscEnv -> PersistentCompilerState +tcRnExpr :: HscEnv -> InteractiveContext -> RdrNameHsExpr - -> IO (PersistentCompilerState, Maybe Type) -tcRnExpr hsc_env pcs ictxt rdr_expr - = initTc hsc_env pcs iNTERACTIVE $ + -> IO (Maybe Type) +tcRnExpr hsc_env ictxt rdr_expr + = initTc hsc_env iNTERACTIVE $ setInteractiveContext ictxt $ do { - (rn_expr, fvs) <- initRnInteractive ictxt (rnExpr rdr_expr) ; + (rn_expr, fvs) <- rnExpr rdr_expr ; failIfErrsM ; - -- Suck in the supporting declarations and typecheck them - tcg_env <- importSupportingDecls (fvs `plusFV` ubiquitousNames) ; - setGblEnv tcg_env $ do { - -- Now typecheck the expression; -- it might have a rank-2 type (e.g. :t runST) ((tc_expr, res_ty), lie) <- getLIE (tcInferRho rn_expr) ; @@ -478,24 +424,24 @@ tcRnExpr hsc_env pcs ictxt rdr_expr mkFunTys (map idType dict_ids) $ res_ty } ; zonkTcType all_expr_ty - }} + } where smpl_doc = ptext SLIT("main expression") \end{code} \begin{code} -tcRnThing :: HscEnv -> PersistentCompilerState +tcRnThing :: HscEnv -> InteractiveContext -> RdrName - -> IO (PersistentCompilerState, Maybe [TyThing]) + -> IO (Maybe [(IfaceDecl, Fixity)]) -- Look up a RdrName and return all the TyThings it might be -- A capitalised RdrName is given to us in the DataName namespace, -- but we want to treat it as *both* a data constructor -- *and* as a type or class constructor; -- hence the call to dataTcOccs, and we return up to two results -tcRnThing hsc_env pcs ictxt rdr_name - = initTc hsc_env pcs iNTERACTIVE $ +tcRnThing hsc_env ictxt rdr_name + = initTc hsc_env iNTERACTIVE $ setInteractiveContext ictxt $ do { -- If the identifier is a constructor (begins with an @@ -504,8 +450,7 @@ tcRnThing hsc_env pcs ictxt rdr_name let { rdr_names = dataTcOccs rdr_name } ; -- results :: [(Messages, Maybe Name)] - results <- initRnInteractive ictxt - (mapM (tryTc . lookupOccRn) rdr_names) ; + results <- mapM (tryTc . lookupOccRn) rdr_names ; -- The successful lookups will be (Just name) let { (warns_s, good_names) = unzip [ (msgs, name) @@ -523,30 +468,32 @@ tcRnThing hsc_env pcs ictxt rdr_name else -- Add deprecation warnings mapM_ addMessages warns_s ; - -- Slurp in the supporting declarations - tcg_env <- importSupportingDecls (mkFVs good_names) ; - setGblEnv tcg_env $ do { - -- And lookup up the entities - mapM tcLookupGlobal good_names - }} + mapM do_one good_names + } + where + do_one name = do { thing <- tcLookupGlobal name + ; fixity <- lookupFixityRn name + ; return (toIfaceDecl ictxt thing, fixity) } + +toIfaceDecl :: InteractiveContext -> TyThing -> IfaceDecl +toIfaceDecl ictxt thing + = tyThingToIfaceDecl True {- Discard IdInfo -} ext_nm thing + where + unqual = icPrintUnqual ictxt + ext_nm n | unqual n = LocalTop (nameOccName n) -- What a hack + | otherwise = ExtPkg (nameModuleName n) (nameOccName n) \end{code} \begin{code} -setInteractiveContext :: InteractiveContext -> TcRn m a -> TcRn m a +setInteractiveContext :: InteractiveContext -> TcRn a -> TcRn a setInteractiveContext icxt thing_inside = traceTc (text "setIC" <+> ppr (ic_type_env icxt)) `thenM_` - updGblEnv (\ env -> env { tcg_rdr_env = ic_rn_gbl_env icxt, - tcg_type_env = ic_type_env icxt }) - thing_inside - -initRnInteractive :: InteractiveContext -> RnM a -> TcM a --- Set the local RdrEnv from the interactive context -initRnInteractive ictxt rn_thing - = initRn CmdLineMode $ - setLocalRdrEnv (ic_rn_local_env ictxt) $ - rn_thing + (updGblEnv (\env -> env {tcg_rdr_env = ic_rn_gbl_env icxt, + tcg_type_env = ic_type_env icxt}) $ + updLclEnv (\env -> env {tcl_rdr = ic_rn_local_env icxt}) $ + thing_inside) #endif /* GHCI */ \end{code} @@ -557,47 +504,46 @@ initRnInteractive ictxt rn_thing %************************************************************************ \begin{code} -tcRnExtCore :: HscEnv -> PersistentCompilerState - -> RdrNameHsModule - -> IO (PersistentCompilerState, Maybe ModGuts) +tcRnExtCore :: HscEnv + -> HsExtCore RdrName + -> IO (Maybe ModGuts) -- Nothing => some error occurred -tcRnExtCore hsc_env pcs (HsModule (Just this_mod) _ _ decls _ loc) - -- For external core, the module name is syntactically reqd - -- Rename the (Core) module. It's a bit like an interface - -- file: all names are original names +tcRnExtCore hsc_env (HsExtCore this_mod decls src_binds) + -- The decls are IfaceDecls; all names are original names = do { showPass (hsc_dflags hsc_env) "Renamer/typechecker" ; - initTc hsc_env pcs this_mod $ addSrcLoc loc $ do { + initTc hsc_env this_mod $ do { - -- Rename the source, only in interface mode. - -- rnSrcDecls handles fixity decls etc too, which won't occur - -- but that doesn't matter - let { local_group = mkGroup decls } ; - (_, rn_src_decls, dus) <- initRn (InterfaceMode this_mod) - (rnSrcDecls local_group) ; - failIfErrsM ; + -- Deal with the type declarations; first bring their stuff + -- into scope, then rname them, then type check them + (rdr_env, imports) <- importsFromLocalDecls $ + HsGroup { hs_tyclds = decls, hs_valds = EmptyBinds, hs_fords = [] } ; + -- Rather clumsy; lots of unused fields - -- Get the supporting decls - rn_imp_decls <- slurpImpDecls (duUses dus) ; - let { rn_decls = rn_src_decls `addImpDecls` rn_imp_decls } ; + updGblEnv (\gbl -> gbl { tcg_rdr_env = rdr_env `plusGlobalRdrEnv` tcg_rdr_env gbl, + tcg_imports = imports `plusImportAvails` tcg_imports gbl }) + $ do { + + rn_decls <- rnTyClDecls decls ; + failIfErrsM ; -- Dump trace of renaming part rnDump (ppr rn_decls) ; - rnStats rn_imp_decls ; -- Typecheck them all together so that -- any mutually recursive types are done right - tcg_env <- typecheckIfaceDecls rn_decls ; + tcg_env <- checkNoErrs (tcTyAndClassDecls rn_decls) ; + -- Make the new type env available to stuff slurped from interface files + setGblEnv tcg_env $ do { -- Now the core bindings - core_prs <- tcCoreBinds (hs_coreds rn_decls) ; - tcExtendGlobalValEnv (map fst core_prs) $ do { - + core_binds <- initIfaceExtCore (tcExtCoreBindings this_mod src_binds) ; + -- Wrap up let { - bndrs = map fst core_prs ; + bndrs = bindersOfBinds core_binds ; my_exports = map (Avail . idName) bndrs ; -- ToDo: export the data types also? @@ -610,8 +556,8 @@ tcRnExtCore hsc_env pcs (HsModule (Just this_mod) _ _ decls _ loc) mg_exports = my_exports, mg_types = final_type_env, mg_insts = tcg_insts tcg_env, - mg_rules = hsCoreRules (tcg_rules tcg_env), - mg_binds = [Rec core_prs], + mg_rules = [], + mg_binds = core_binds, -- Stubs mg_rdr_env = emptyGlobalRdrEnv, @@ -634,12 +580,12 @@ tcRnExtCore hsc_env pcs (HsModule (Just this_mod) _ _ decls _ loc) %************************************************************************ \begin{code} -tcRnSrcDecls :: [RdrNameHsDecl] -> TcM (TcGblEnv, DefUses) +tcRnSrcDecls :: [RdrNameHsDecl] -> TcM TcGblEnv -- Returns the variables free in the decls -- Reason: solely to report unused imports and bindings tcRnSrcDecls decls - = do { -- Do all the declarations - ((tc_envs, dus), lie) <- getLIE (tc_rn_src_decls decls) ; + = do { -- Do all the declarations + (tc_envs, lie) <- getLIE (tc_rn_src_decls decls) ; -- tcSimplifyTop deals with constant or ambiguous InstIds. -- How could there be ambiguous ones? They can only arise if a @@ -648,11 +594,10 @@ tcRnSrcDecls decls -- type. (Usually, ambiguous type variables are resolved -- during the generalisation step.) traceTc (text "Tc8") ; - setEnvs tc_envs $ do { + inst_binds <- setEnvs tc_envs (tcSimplifyTop lie) ; -- Setting the global env exposes the instances to tcSimplifyTop - -- Setting the local env exposes the local Ids, so that - -- we get better error messages (monomorphism restriction) - inst_binds <- tcSimplifyTop lie ; + -- Setting the local env exposes the local Ids to tcSimplifyTop, + -- so that we get better error messages (monomorphism restriction) -- Backsubstitution. This must be done last. -- Even tcSimplifyTop may do some unification. @@ -664,19 +609,24 @@ tcRnSrcDecls decls (bind_ids, binds', fords', rules') <- zonkTopDecls (binds `andMonoBinds` inst_binds) rules fords ; - return (tcg_env { tcg_type_env = extendTypeEnvWithIds type_env bind_ids, - tcg_binds = binds', tcg_rules = rules', tcg_fords = fords' }, - dus) - }} + let { final_type_env = extendTypeEnvWithIds type_env bind_ids } ; -tc_rn_src_decls :: [RdrNameHsDecl] -> TcM ((TcGblEnv, TcLclEnv), DefUses) + -- Make the new type env available to stuff slurped from interface files + writeMutVar (tcg_type_env_var tcg_env) final_type_env ; + + return (tcg_env { tcg_type_env = final_type_env, + tcg_binds = binds', tcg_rules = rules', tcg_fords = fords' }) + } +tc_rn_src_decls :: [RdrNameHsDecl] -> TcM (TcGblEnv, TcLclEnv) +-- Loops around dealing with each top level inter-splice group +-- in turn, until it's dealt with the entire module tc_rn_src_decls ds = do { let { (first_group, group_tail) = findSplice ds } ; -- If ds is [] we get ([], Nothing) -- Type check the decls up to, but not including, the first splice - (tc_envs@(_,tcl_env), src_dus1) <- tcRnGroup first_group ; + tc_envs@(tcg_env,tcl_env) <- tcRnGroup first_group ; -- Bale out if errors; for example, error recovery when checking -- the RHS of 'main' can mean that 'main' is not in the envt for @@ -688,9 +638,8 @@ tc_rn_src_decls ds -- If there is no splice, we're nearly done case group_tail of { Nothing -> do { -- Last thing: check for `main' - (tcg_env, main_fvs) <- checkMain ; - return ((tcg_env, tcl_env), - src_dus1 `plusDU` usesOnly main_fvs) + tcg_env <- checkMain ; + return (tcg_env, tcl_env) } ; -- If there's a splice, we must carry on @@ -700,20 +649,14 @@ tc_rn_src_decls ds #else -- Rename the splice expression, and get its supporting decls - (rn_splice_expr, splice_fvs) <- initRn SourceMode $ - addSrcLoc splice_loc $ + (rn_splice_expr, splice_fvs) <- addSrcLoc splice_loc $ rnExpr splice_expr ; - tcg_env <- importSupportingDecls (splice_fvs `plusFV` templateHaskellNames) ; - setGblEnv tcg_env $ do { - -- Execute the splice spliced_decls <- tcSpliceDecls rn_splice_expr ; -- Glue them on the front of the remaining decls and loop - (tc_envs, src_dus2) <- tc_rn_src_decls (spliced_decls ++ rest_ds) ; - - return (tc_envs, src_dus1 `plusDU` usesOnly splice_fvs `plusDU` src_dus2) - } + setGblEnv (tcg_env `addTcgDUs` usesOnly splice_fvs) $ + tc_rn_src_decls (spliced_decls ++ rest_ds) #endif /* GHCI */ }}} \end{code} @@ -737,49 +680,37 @@ declarations. It expects there to be an incoming TcGblEnv in the monad; it augments it and returns the new TcGblEnv. \begin{code} -tcRnGroup :: HsGroup RdrName -> TcM ((TcGblEnv, TcLclEnv), DefUses) +tcRnGroup :: HsGroup RdrName -> TcM (TcGblEnv, TcLclEnv) -- Returns the variables free in the decls, for unused-binding reporting tcRnGroup decls = do { -- Rename the declarations - (tcg_env, rn_decls, src_dus) <- rnTopSrcDecls decls ; + (tcg_env, rn_decls) <- rnTopSrcDecls decls ; setGblEnv tcg_env $ do { -- Typecheck the declarations - tc_envs <- tcTopSrcDecls rn_decls ; - - return (tc_envs, src_dus) + tcTopSrcDecls rn_decls }} ------------------------------------------------ -rnTopSrcDecls :: HsGroup RdrName -> TcM (TcGblEnv, HsGroup Name, DefUses) +rnTopSrcDecls :: HsGroup RdrName -> TcM (TcGblEnv, HsGroup Name) rnTopSrcDecls group = do { -- Bring top level binders into scope (rdr_env, imports) <- importsFromLocalDecls group ; - updGblEnv (\gbl -> gbl { tcg_rdr_env = rdr_env `plusGlobalRdrEnv` - tcg_rdr_env gbl, - tcg_imports = imports `plusImportAvails` - tcg_imports gbl }) - $ do { + updGblEnv (\gbl -> gbl { tcg_rdr_env = rdr_env `plusGlobalRdrEnv` tcg_rdr_env gbl, + tcg_imports = imports `plusImportAvails` tcg_imports gbl }) + $ do { failIfErrsM ; -- No point in continuing if (say) we have duplicate declarations -- Rename the source decls - (tcg_env, rn_src_decls, src_dus) <- initRn SourceMode (rnSrcDecls group) ; - setGblEnv tcg_env $ do { - + (tcg_env, rn_decls) <- rnSrcDecls group ; failIfErrsM ; - -- Import consquential imports - let { src_fvs = duUses src_dus } ; - rn_imp_decls <- slurpImpDecls (src_fvs `plusFV` implicitModuleFVs src_fvs) ; - let { rn_decls = rn_src_decls `addImpDecls` rn_imp_decls } ; - -- Dump trace of renaming part rnDump (ppr rn_decls) ; - rnStats rn_imp_decls ; - return (tcg_env, rn_decls, src_dus) - }}} + return (tcg_env, rn_decls) + }} ------------------------------------------------ tcTopSrcDecls :: HsGroup Name -> TcM (TcGblEnv, TcLclEnv) @@ -793,24 +724,27 @@ tcTopSrcDecls = do { -- Type-check the type and class decls, and all imported decls -- The latter come in via tycl_decls traceTc (text "Tc2") ; - tcg_env <- tcTyClDecls tycl_decls ; - setGblEnv tcg_env $ do { + tcg_env <- checkNoErrs (tcTyAndClassDecls tycl_decls) ; + -- tcTyAndClassDecls recovers internally, but if anything gave rise to + -- an error we'd better stop now, to avoid a cascade + + -- Make these type and class decls available to stuff slurped from interface files + writeMutVar (tcg_type_env_var tcg_env) (tcg_type_env tcg_env) ; + + + setGblEnv tcg_env $ do { -- Source-language instances, including derivings, -- and import the supporting declarations traceTc (text "Tc3") ; - (tcg_env, inst_infos, deriv_binds, fvs) <- tcInstDecls1 tycl_decls inst_decls ; - setGblEnv tcg_env $ do { - tcg_env <- importSupportingDecls fvs ; + (tcg_env, inst_infos, deriv_binds) <- tcInstDecls1 tycl_decls inst_decls ; setGblEnv tcg_env $ do { -- Foreign import declarations next. No zonking necessary -- here; we can tuck them straight into the global environment. traceTc (text "Tc4") ; (fi_ids, fi_decls) <- tcForeignImports foreign_decls ; - tcExtendGlobalValEnv fi_ids $ - updGblEnv (\gbl -> gbl { tcg_fords = tcg_fords gbl ++ fi_decls }) - $ do { + tcExtendGlobalValEnv fi_ids $ do { -- Default declarations traceTc (text "Tc4a") ; @@ -819,17 +753,14 @@ tcTopSrcDecls -- Value declarations next -- We also typecheck any extra binds that came out - -- of the "deriving" process + -- of the "deriving" process (deriv_binds) traceTc (text "Tc5") ; (tc_val_binds, lcl_env) <- tcTopBinds (val_binds `ThenBinds` deriv_binds) ; setLclTypeEnv lcl_env $ do { -- Second pass over class and instance declarations, - -- plus rules and foreign exports, to generate bindings traceTc (text "Tc6") ; - (cls_dm_binds, dm_ids) <- tcClassDecls2 tycl_decls ; - tcExtendGlobalValEnv dm_ids $ do { - inst_binds <- tcInstDecls2 inst_infos ; + (tcl_env, inst_binds) <- tcInstDecls2 tycl_decls inst_infos ; showLIE (text "after instDecls2") ; -- Foreign exports @@ -838,192 +769,25 @@ tcTopSrcDecls (foe_binds, foe_decls) <- tcForeignExports foreign_decls ; -- Rules - -- Need to partition them because the source rules - -- must be zonked before adding them to tcg_rules - -- NB: built-in rules come in as IfaceRuleOut's, and - -- get added to tcg_rules right here by tcExtendRules rules <- tcRules rule_decls ; - let { (src_rules, iface_rules) = partition isSrcRule rules } ; - tcExtendRules iface_rules $ do { -- Wrap up + traceTc (text "Tc7a") ; tcg_env <- getGblEnv ; let { all_binds = tc_val_binds `AndMonoBinds` inst_binds `AndMonoBinds` - cls_dm_binds `AndMonoBinds` foe_binds ; -- Extend the GblEnv with the (as yet un-zonked) -- bindings, rules, foreign decls tcg_env' = tcg_env { tcg_binds = tcg_binds tcg_env `andMonoBinds` all_binds, - tcg_rules = tcg_rules tcg_env ++ src_rules, - tcg_fords = tcg_fords tcg_env ++ foe_decls } } ; - + tcg_rules = tcg_rules tcg_env ++ rules, + tcg_fords = tcg_fords tcg_env ++ foe_decls ++ fi_decls } } ; return (tcg_env', lcl_env) - }}}}}}}}} -\end{code} - -\begin{code} -tcTyClDecls :: [RenamedTyClDecl] - -> TcM TcGblEnv - --- tcTyClDecls deals with --- type and class decls (some source, some imported) --- interface signatures (checked lazily) --- --- It returns the TcGblEnv for this module, and side-effects the --- persistent compiler state to reflect the things imported from --- other modules - -tcTyClDecls tycl_decls - = checkNoErrs $ - -- tcTyAndClassDecls recovers internally, but if anything gave rise to - -- an error we'd better stop now, to avoid a cascade - - traceTc (text "TyCl1") `thenM_` - tcTyAndClassDecls tycl_decls `thenM` \ tcg_env -> - -- Returns the extended environment - setGblEnv tcg_env $ - - traceTc (text "TyCl2") `thenM_` - tcInterfaceSigs tycl_decls `thenM` \ tcg_env -> - -- Returns the extended environment - - returnM tcg_env -\end{code} - - - -%************************************************************************ -%* * - Load the old interface file for this module (unless - we have it aleady), and check whether it is up to date - -%* * -%************************************************************************ - -\begin{code} -checkOldIface :: HscEnv - -> PersistentCompilerState - -> Module - -> FilePath -- Where the interface file is - -> Bool -- Source unchanged - -> Maybe ModIface -- Old interface from compilation manager, if any - -> IO (PersistentCompilerState, Maybe (RecompileRequired, Maybe ModIface)) - -- Nothing <=> errors happened - -checkOldIface hsc_env pcs mod iface_path source_unchanged maybe_iface - = do { showPass (hsc_dflags hsc_env) - ("Checking old interface for " ++ moduleUserString mod) ; - - initTc hsc_env pcs mod - (check_old_iface iface_path source_unchanged maybe_iface) - } - -check_old_iface iface_path source_unchanged maybe_iface - = -- CHECK WHETHER THE SOURCE HAS CHANGED - ifM (not source_unchanged) - (traceHiDiffs (nest 4 (text "Source file changed or recompilation check turned off"))) - `thenM_` - - -- If the source has changed and we're in interactive mode, avoid reading - -- an interface; just return the one we might have been supplied with. - getGhciMode `thenM` \ ghci_mode -> - if (ghci_mode == Interactive) && not source_unchanged then - returnM (outOfDate, maybe_iface) - else - - case maybe_iface of { - Just old_iface -> -- Use the one we already have - checkVersions source_unchanged old_iface `thenM` \ recomp -> - returnM (recomp, Just old_iface) - - ; Nothing -> - - -- Try and read the old interface for the current module - -- from the .hi file left from the last time we compiled it - getModule `thenM` \ this_mod -> - readIface this_mod iface_path False `thenM` \ read_result -> - case read_result of { - Left err -> -- Old interface file not found, or garbled; give up - traceHiDiffs (text "FYI: cannot read old interface file:" - $$ nest 4 (text (showException err))) `thenM_` - returnM (outOfDate, Nothing) - - ; Right parsed_iface -> - - -- We found the file and parsed it; now load it - tryTc (initRn (InterfaceMode this_mod) - (loadOldIface parsed_iface)) `thenM` \ ((_,errs), mb_iface) -> - case mb_iface of { - Nothing -> -- Something went wrong in loading. The main likely thing - -- is that the usages mentioned B.f, where B.hi and B.hs no - -- longer exist. Then newGlobalName2 fails with an error message - -- This isn't an error; we just don't have an old iface file to - -- look at. Spit out a traceHiDiffs for info though. - traceHiDiffs (text "FYI: loading old interface file failed" - $$ nest 4 (docToSDoc (pprBagOfErrors errs))) `thenM_` - return (outOfDate, Nothing) - - ; Just iface -> - - -- At last, we have got the old iface; check its versions - checkVersions source_unchanged iface `thenM` \ recomp -> - returnM (recomp, Just iface) - }}} -\end{code} - - -%************************************************************************ -%* * - Type-check and rename supporting declarations - This is used to deal with the free vars of a splice, - or derived code: slurp in the necessary declarations, - typecheck them, and add them to the EPS -%* * -%************************************************************************ - -\begin{code} -importSupportingDecls :: FreeVars -> TcM TcGblEnv --- Completely deal with the supporting imports needed --- by the specified free-var set -importSupportingDecls fvs - = do { traceRn (text "Import supporting decls for" <+> ppr (nameSetToList fvs)) ; - decls <- slurpImpDecls fvs ; - traceRn (text "...namely:" <+> vcat (map ppr decls)) ; - typecheckIfaceDecls (mkGroup decls) } - -typecheckIfaceDecls :: HsGroup Name -> TcM TcGblEnv - -- The decls are all interface-file declarations - -- Usually they are all from other modules, but when we are reading - -- this module's interface from a file, it's possible that some of - -- them are for the module being compiled. - -- That is why the tcExtendX functions need to do partitioning. - -- - -- If all the decls are from other modules, the returned TcGblEnv - -- will have an empty tc_genv, but its tc_inst_env - -- cache may have been augmented. -typecheckIfaceDecls (HsGroup { hs_tyclds = tycl_decls, - hs_instds = inst_decls, - hs_ruleds = rule_decls }) - = do { -- Typecheck the type, class, and interface-sig decls - tcg_env <- tcTyClDecls tycl_decls ; - setGblEnv tcg_env $ do { - - -- Typecheck the instance decls, and rules - -- Note that imported dictionary functions are already - -- in scope from the preceding tcTyClDecls - tcIfaceInstDecls inst_decls `thenM` \ dfuns -> - tcExtendInstEnv dfuns $ - tcRules rule_decls `thenM` \ rules -> - tcExtendRules rules $ - - getGblEnv -- Return the environment - }} + }}}}}} \end{code} - %********************************************************* %* * mkGlobalContext: make up an interactive context @@ -1035,83 +799,85 @@ typecheckIfaceDecls (HsGroup { hs_tyclds = tycl_decls, \begin{code} #ifdef GHCI -mkGlobalContext - :: HscEnv -> PersistentCompilerState - -> [Module] -- Expose these modules' top-level scope - -> [Module] -- Expose these modules' exports only - -> IO (PersistentCompilerState, Maybe GlobalRdrEnv) +mkExportEnv :: HscEnv -> [ModuleName] -- Expose these modules' exports only + -> IO GlobalRdrEnv -mkGlobalContext hsc_env pcs toplevs exports - = initTc hsc_env pcs iNTERACTIVE $ do { - - toplev_envs <- mappM getTopLevScope toplevs ; +mkExportEnv hsc_env exports + = initIfaceIO hsc_env $ do { export_envs <- mappM getModuleExports exports ; - returnM (foldr plusGlobalRdrEnv emptyGlobalRdrEnv - (toplev_envs ++ export_envs)) + returnM (foldr plusGlobalRdrEnv emptyGlobalRdrEnv export_envs) } -getTopLevScope :: Module -> TcRn m GlobalRdrEnv -getTopLevScope mod - = do { iface <- loadInterface contextDoc (moduleName mod) (ImportByUser False) ; - case mi_globals iface of - Nothing -> panic "getTopLevScope" - Just env -> returnM env } - -getModuleExports :: Module -> TcRn m GlobalRdrEnv +getModuleExports :: ModuleName -> IfG GlobalRdrEnv getModuleExports mod - = do { iface <- loadInterface contextDoc (moduleName mod) (ImportByUser False) ; - returnM (foldl add emptyGlobalRdrEnv (mi_exports iface)) } - where - prov_fn n = NonLocalDef ImplicitImport - add env (mod,avails) - = plusGlobalRdrEnv env (mkGlobalRdrEnv mod True prov_fn avails NoDeprecs) - -contextDoc = text "context for compiling statements" + = do { iface <- load_iface mod + ; avails <- exportsToAvails (mi_exports iface) + ; let { gres = [ GRE { gre_name = name, gre_prov = vanillaProv mod, + gre_deprec = mi_dep_fn iface name } + | avail <- avails, name <- availNames avail ] } + ; returnM (mkGlobalRdrEnv gres) } + +vanillaProv :: ModuleName -> Provenance +-- We're building a GlobalRdrEnv as if the user imported +-- all the specified modules into the global interactive module +vanillaProv mod = Imported [ImportSpec mod mod False interactiveSrcLoc] False \end{code} \begin{code} getModuleContents :: HscEnv - -> PersistentCompilerState -- IN: persistent compiler state - -> Module -- module to inspect - -> Bool -- grab just the exports, or the whole toplev - -> IO (PersistentCompilerState, Maybe [TyThing]) - -getModuleContents hsc_env pcs mod exports_only - = initTc hsc_env pcs iNTERACTIVE $ do { - - -- Load the interface if necessary (a home module will certainly - -- alraedy be loaded, but a package module might not be) - iface <- loadInterface contextDoc (moduleName mod) (ImportByUser False) ; - - let { export_names = availsToNameSet export_avails ; - export_avails = [ avail | (mn, avails) <- mi_exports iface, - avail <- avails ] } ; - - all_names <- if exports_only then - return export_names - else case mi_globals iface of { - Just rdr_env -> - return (get_locals rdr_env) ; - - Nothing -> do { addErr (noRdrEnvErr mod) ; - return export_names } } ; - -- Invariant; we only have (not exports_only) - -- for a home module so it must already be in the HIT - -- So the Nothing case is a bug - - env <- importSupportingDecls all_names ; - setGblEnv env (mappM tcLookupGlobal (nameSetToList all_names)) - } - where - -- Grab all the things from the global env that are locally def'd - get_locals rdr_env = mkNameSet [ gre_name gre - | elts <- rdrEnvElts rdr_env, - gre <- elts, - isLocalGRE gre ] - -- Make a set because a name is often in the envt in - -- both qualified and unqualified forms - + -> InteractiveContext + -> ModuleName -- Module to inspect + -> Bool -- Grab just the exports, or the whole toplev + -> IO [IfaceDecl] + +getModuleContents hsc_env ictxt mod exports_only + = initIfaceIO hsc_env (get_mod_contents exports_only) + where + get_mod_contents exports_only + | not exports_only -- We want the whole top-level type env + -- so it had better be a home module + = do { hpt <- getHpt + ; case lookupModuleEnvByName hpt mod of + Just mod_info -> return (map (toIfaceDecl ictxt) $ + filter wantToSee $ + typeEnvElts $ + md_types (hm_details mod_info)) + Nothing -> ghcError (ProgramError (showSDoc (noRdrEnvErr mod))) + -- This is a system error; the module should be in the HPT + } + + | otherwise -- Want the exports only + = do { iface <- load_iface mod + ; avails <- exportsToAvails (mi_exports iface) + ; mappM get_decl avails + } + + get_decl avail + = do { thing <- tcIfaceGlobal (availName avail) + ; return (filter_decl (availOccs avail) (toIfaceDecl ictxt thing)) } + +--------------------- +filter_decl occs decl@(IfaceClass {ifSigs = sigs}) + = decl { ifSigs = filter (keep_sig occs) sigs } +filter_decl occs decl@(IfaceData {ifCons = DataCons cons}) + = decl { ifCons = DataCons (filter (keep_con occs) cons) } +filter_decl occs decl + = decl + +keep_sig occs (IfaceClassOp occ _ _) = occ `elem` occs +keep_con occs (IfaceConDecl occ _ _ _ _ _) = occ `elem` occs + +availOccs avail = map nameOccName (availNames avail) + +wantToSee (AnId id) = not (isImplicitId id) +wantToSee (ADataCon _) = False -- They'll come via their TyCon +wantToSee _ = True + +--------------------- +load_iface mod = loadSysInterface (text "context for compiling statements") mod + +--------------------- noRdrEnvErr mod = ptext SLIT("No top-level environment available for module") <+> quotes (ppr mod) #endif @@ -1143,54 +909,42 @@ checkMain check_main ghci_mode tcg_env main_mod main_fn -- If we are in module Main, check that 'main' is defined. - -- It may be imported from another module, in which case - -- we have to drag in its. - -- - -- Also form the definition - -- $main = runIO main - -- so we need to slurp in runIO too. + -- It may be imported from another module! -- -- ToDo: We have to return the main_name separately, because it's a -- bona fide 'use', and should be recorded as such, but the others -- aren't -- -- Blimey: a whole page of code to do this... - | mod_name /= main_mod - = return (tcg_env, emptyFVs) - - -- Check that 'main' is in scope - -- It might be imported from another module! - -- - -- We use a guard for this (rather than letting lookupSrcName fail) - -- because it's not an error in ghci) - | not (main_fn `elemRdrEnv` rdr_env) - = do { complain_no_main; return (tcg_env, emptyFVs) } - - | otherwise -- OK, so the appropriate 'main' is in scope - -- - = do { main_name <- lookupSrcName main_fn ; - - tcg_env <- importSupportingDecls (unitFV runIOName) ; - - addSrcLoc (getSrcLoc main_name) $ - addErrCtxt mainCtxt $ - setGblEnv tcg_env $ do { - - -- :Main.main :: IO () = runIO main - let { rhs = HsApp (HsVar runIOName) (HsVar main_name) } ; - (main_expr, ty) <- tcInferRho rhs ; - - let { root_main_id = setIdLocalExported (mkLocalId rootMainName ty) ; - main_bind = VarMonoBind root_main_id main_expr ; - tcg_env' = tcg_env { tcg_binds = tcg_binds tcg_env - `andMonoBinds` main_bind } } ; - - return (tcg_env', unitFV main_name) - }} + = return tcg_env + + | otherwise + = addErrCtxt mainCtxt $ + do { mb_main <- lookupSrcOcc_maybe main_fn + -- Check that 'main' is in scope + -- It might be imported from another module! + ; case mb_main of { + Nothing -> do { complain_no_main + ; return tcg_env } ; + Just main_name -> do + { let { rhs = HsApp (HsVar runIOName) (HsVar main_name) } + -- :Main.main :: IO () = runIO main + + ; (main_expr, ty) <- addSrcLoc (getSrcLoc main_name) $ + tcInferRho rhs + + ; let { root_main_id = setIdLocalExported (mkLocalId rootMainName ty) ; + main_bind = VarMonoBind root_main_id main_expr } + + ; return (tcg_env { tcg_binds = tcg_binds tcg_env + `andMonoBinds` main_bind, + tcg_dus = tcg_dus tcg_env + `plusDU` usesOnly (unitFV main_name) + }) + }}} where mod_name = moduleName (tcg_mod tcg_env) - rdr_env = tcg_rdr_env tcg_env complain_no_main | ghci_mode == Interactive = return () | otherwise = failWithTc noMainMsg @@ -1211,11 +965,11 @@ check_main ghci_mode tcg_env main_mod main_fn %************************************************************************ \begin{code} -rnDump :: SDoc -> TcRn m () +rnDump :: SDoc -> TcRn () -- Dump, with a banner, if -ddump-rn -rnDump doc = dumpOptTcRn Opt_D_dump_rn (mkDumpDoc "Renamer" doc) +rnDump doc = do { dumpOptTcRn Opt_D_dump_rn (mkDumpDoc "Renamer" doc) } -tcDump :: TcGblEnv -> TcRn m () +tcDump :: TcGblEnv -> TcRn () tcDump env = do { dflags <- getDOpts ; @@ -1282,16 +1036,11 @@ ppr_insts dfun_ids = text "INSTANCES" $$ nest 4 (ppr_sigs dfun_ids) ppr_sigs :: [Var] -> SDoc ppr_sigs ids - -- Print type signatures - -- Convert to HsType so that we get source-language style printing - -- And sort by RdrName - = vcat $ map ppr_sig $ sortLt lt_sig $ - [ (getRdrName id, toHsType (tidyTopType (idType id))) - | id <- ids ] + -- Print type signatures; sort by OccName + = vcat (map ppr_sig (sortLt lt_sig ids)) where - lt_sig (n1,_) (n2,_) = n1 < n2 - ppr_sig (n,t) = ppr n <+> dcolon <+> ppr t - + lt_sig id1 id2 = getOccName id1 < getOccName id2 + ppr_sig id = ppr id <+> dcolon <+> ppr (tidyTopType (idType id)) ppr_rules :: [IdCoreRule] -> SDoc ppr_rules [] = empty @@ -1300,22 +1049,6 @@ ppr_rules rs = vcat [ptext SLIT("{-# RULES"), ptext SLIT("#-}")] ppr_gen_tycons [] = empty -ppr_gen_tycons tcs = vcat [ptext SLIT("Generic type constructor details:"), - nest 2 (vcat (map ppr_gen_tycon tcs)) - ] - --- x&y are now Id's, not CoreExpr's -ppr_gen_tycon tycon - | Just ep <- tyConGenInfo tycon - = (ppr tycon <> colon) $$ nest 4 (ppr_ep ep) - - | otherwise = ppr tycon <> colon <+> ptext SLIT("Not derivable") - -ppr_ep (EP from to) - = vcat [ ptext SLIT("Rep type:") <+> ppr (tcFunResultTy from_tau), - ptext SLIT("From:") <+> ppr (unfoldingTemplate (idUnfolding from)), - ptext SLIT("To:") <+> ppr (unfoldingTemplate (idUnfolding to)) - ] - where - (_,from_tau) = tcSplitForAllTys (idType from) +ppr_gen_tycons tcs = vcat [ptext SLIT("Tycons with generics:"), + nest 2 (fsep (map ppr (filter tyConHasGenerics tcs)))] \end{code} diff --git a/ghc/compiler/typecheck/TcRnMonad.lhs b/ghc/compiler/typecheck/TcRnMonad.lhs index 835752e0e0..5dce531ac1 100644 --- a/ghc/compiler/typecheck/TcRnMonad.lhs +++ b/ghc/compiler/typecheck/TcRnMonad.lhs @@ -1,39 +1,44 @@ \begin{code} module TcRnMonad( module TcRnMonad, - module TcRnTypes + module TcRnTypes, + module IOEnv ) where #include "HsVersions.h" +import TcRnTypes -- Re-export all +import IOEnv -- Re-export all + import HsSyn ( MonoBinds(..) ) -import HscTypes ( HscEnv(..), PersistentCompilerState(..), - emptyFixityEnv, emptyGlobalRdrEnv, TyThing, +import HscTypes ( HscEnv(..), + TyThing, ExternalPackageState(..), HomePackageTable, - ModDetails(..), HomeModInfo(..), Deprecations(..), - GlobalRdrEnv, LocalRdrEnv, NameCache, FixityEnv, + ModDetails(..), HomeModInfo(..), + Deprecs(..), FixityEnv, FixItem, GhciMode, lookupType, unQualInScope ) -import TcRnTypes -import Module ( Module, unitModuleEnv, foldModuleEnv ) +import Module ( Module, ModuleName, unitModuleEnv, foldModuleEnv, emptyModuleEnv ) +import RdrName ( GlobalRdrEnv, emptyGlobalRdrEnv, + LocalRdrEnv, emptyLocalRdrEnv ) import Name ( Name, isInternalName ) import Type ( Type ) import NameEnv ( extendNameEnvList ) -import InstEnv ( InstEnv, extendInstEnv ) -import TysWiredIn ( integerTy, doubleTy ) +import InstEnv ( InstEnv, emptyInstEnv, extendInstEnv ) import VarSet ( emptyVarSet ) import VarEnv ( TidyEnv, emptyTidyEnv ) -import RdrName ( emptyRdrEnv ) import ErrUtils ( Message, Messages, emptyMessages, errorsFound, addShortErrLocLine, addShortWarnLocLine, printErrorsAndWarnings ) -import SrcLoc ( SrcLoc, noSrcLoc ) +import SrcLoc ( SrcLoc, mkGeneralSrcLoc ) import NameEnv ( emptyNameEnv ) +import NameSet ( emptyDUs, emptyNameSet ) +import OccName ( emptyOccEnv ) +import Module ( moduleName ) import Bag ( emptyBag ) import Outputable import UniqSupply ( UniqSupply, mkSplitUniqSupply, uniqFromSupply, splitUniqSupply ) import Unique ( Unique ) import CmdLineOpts ( DynFlags, DynFlag(..), dopt, opt_PprStyle_Debug ) -import BasicTypes ( FixitySig ) import Bag ( snocBag, unionBags ) import Panic ( showException ) @@ -43,52 +48,6 @@ import DATA_IOREF ( newIORef, readIORef ) import EXCEPTION ( Exception ) \end{code} -%************************************************************************ -%* * - Standard combinators, but specialised for this monad - (for efficiency) -%* * -6%************************************************************************ - -\begin{code} -mappM :: (a -> TcRn m b) -> [a] -> TcRn m [b] -mappM_ :: (a -> TcRn m b) -> [a] -> TcRn m () - -- Funny names to avoid clash with Prelude -sequenceM :: [TcRn m a] -> TcRn m [a] -foldlM :: (a -> b -> TcRn m a) -> a -> [b] -> TcRn m a -mapAndUnzipM :: (a -> TcRn m (b,c)) -> [a] -> TcRn m ([b],[c]) -mapAndUnzip3M :: (a -> TcRn m (b,c,d)) -> [a] -> TcRn m ([b],[c],[d]) -checkM :: Bool -> TcRn m () -> TcRn m () -- Perform arg if bool is False -ifM :: Bool -> TcRn m () -> TcRn m () -- Perform arg if bool is True - -mappM f [] = return [] -mappM f (x:xs) = do { r <- f x; rs <- mappM f xs; return (r:rs) } - -mappM_ f [] = return () -mappM_ f (x:xs) = f x >> mappM_ f xs - -sequenceM [] = return [] -sequenceM (x:xs) = do { r <- x; rs <- sequenceM xs; return (r:rs) } - -foldlM k z [] = return z -foldlM k z (x:xs) = do { r <- k z x; foldlM k r xs } - -mapAndUnzipM f [] = return ([],[]) -mapAndUnzipM f (x:xs) = do { (r,s) <- f x; - (rs,ss) <- mapAndUnzipM f xs; - return (r:rs, s:ss) } - -mapAndUnzip3M f [] = return ([],[], []) -mapAndUnzip3M f (x:xs) = do { (r,s,t) <- f x; - (rs,ss,ts) <- mapAndUnzip3M f xs; - return (r:rs, s:ss, t:ts) } - -checkM True err = return () -checkM False err = err - -ifM True do_it = do_it -ifM False do_it = return () -\end{code} %************************************************************************ @@ -98,114 +57,89 @@ ifM False do_it = return () %************************************************************************ \begin{code} -initTc :: HscEnv -> PersistentCompilerState +ioToTcRn :: IO r -> TcRn r +ioToTcRn = ioToIOEnv +\end{code} + +\begin{code} +initTc :: HscEnv -> Module -> TcM r - -> IO (PersistentCompilerState, Maybe r) + -> IO (Maybe r) -- Nothing => error thrown by the thing inside -- (error messages should have been printed already) -initTc (HscEnv { hsc_mode = ghci_mode, - hsc_HPT = hpt, - hsc_dflags = dflags }) - pcs mod do_this - = do { us <- mkSplitUniqSupply 'a' ; - us_var <- newIORef us ; - errs_var <- newIORef (emptyBag, emptyBag) ; - tvs_var <- newIORef emptyVarSet ; - usg_var <- newIORef emptyUsages ; - nc_var <- newIORef (pcs_nc pcs) ; - eps_var <- newIORef eps ; - ie_var <- newIORef (mkImpInstEnv dflags eps hpt) ; +initTc hsc_env mod do_this + = do { errs_var <- newIORef (emptyBag, emptyBag) ; + tvs_var <- newIORef emptyVarSet ; + type_env_var <- newIORef emptyNameEnv ; + dfuns_var <- newIORef emptyNameSet ; let { - env = Env { env_top = top_env, - env_gbl = gbl_env, - env_lcl = lcl_env, - env_loc = noSrcLoc } ; - - top_env = TopEnv { - top_mode = ghci_mode, - top_dflags = dflags, - top_eps = eps_var, - top_hpt = hpt, - top_nc = nc_var, - top_us = us_var, - top_errs = errs_var } ; - gbl_env = TcGblEnv { tcg_mod = mod, - tcg_usages = usg_var, tcg_rdr_env = emptyGlobalRdrEnv, - tcg_fix_env = emptyFixityEnv, - tcg_default = defaultDefaultTys, + tcg_fix_env = emptyNameEnv, + tcg_default = Nothing, tcg_type_env = emptyNameEnv, - tcg_inst_env = ie_var, + tcg_type_env_var = type_env_var, + tcg_inst_env = mkImpInstEnv hsc_env, + tcg_inst_uses = dfuns_var, tcg_exports = [], tcg_imports = init_imports, + tcg_dus = emptyDUs, tcg_binds = EmptyMonoBinds, tcg_deprecs = NoDeprecs, tcg_insts = [], tcg_rules = [], - tcg_fords = [] } ; - + tcg_fords = [] + } ; lcl_env = TcLclEnv { + tcl_errs = errs_var, + tcl_loc = mkGeneralSrcLoc FSLIT("Top level of module"), tcl_ctxt = [], + tcl_rdr = emptyLocalRdrEnv, tcl_th_ctxt = topStage, tcl_arrow_ctxt = topArrowCtxt, tcl_env = emptyNameEnv, tcl_tyvars = tvs_var, - tcl_lie = panic "initTc:LIE" } ; - -- LIE only valid inside a getLIE + tcl_lie = panic "initTc:LIE" -- LIE only valid inside a getLIE } ; + } ; -- OK, here's the business end! - maybe_res <- catch (do { res <- runTcRn env do_this ; - return (Just res) }) - (\_ -> return Nothing) ; + maybe_res <- initTcRnIf 'a' hsc_env gbl_env lcl_env $ + do { r <- tryM do_this + ; case r of + Right res -> return (Just res) + Left _ -> return Nothing } ; -- Print any error messages msgs <- readIORef errs_var ; printErrorsAndWarnings msgs ; - -- Get final PCS and return - eps' <- readIORef eps_var ; - nc' <- readIORef nc_var ; - let { pcs' = PCS { pcs_EPS = eps', pcs_nc = nc' } ; - final_res | errorsFound dflags msgs = Nothing + let { dflags = hsc_dflags hsc_env + ; final_res | errorsFound dflags msgs = Nothing | otherwise = maybe_res } ; - return (pcs', final_res) + return final_res } where - eps = pcs_EPS pcs - init_imports = emptyImportAvails { imp_qual = unitModuleEnv mod emptyAvailEnv } -- Initialise tcg_imports with an empty set of bindings for -- this module, so that if we see 'module M' in the export -- list, and there are no bindings in M, we don't bleat -- "unknown module M". -defaultDefaultTys :: [Type] -defaultDefaultTys = [integerTy, doubleTy] - -mkImpInstEnv :: DynFlags -> ExternalPackageState -> HomePackageTable -> InstEnv +mkImpInstEnv :: HscEnv -> InstEnv -- At the moment we (wrongly) build an instance environment from all the --- modules we have already compiled: --- (a) eps_inst_env from the external package state --- (b) all the md_insts in the home package table +-- home-package modules we have already compiled. -- We should really only get instances from modules below us in the -- module import tree. -mkImpInstEnv dflags eps hpt - = foldModuleEnv (add . md_insts . hm_details) - (eps_inst_env eps) - hpt +mkImpInstEnv (HscEnv {hsc_dflags = dflags, hsc_HPT = hpt}) + = foldModuleEnv (add . md_insts . hm_details) emptyInstEnv hpt where - -- We shouldn't get instance conflict errors from - -- the package and home type envs - add dfuns inst_env = WARN( not (null errs), vcat (map snd errs) ) inst_env' - where - (inst_env', errs) = extendInstEnv dflags inst_env dfuns + add dfuns inst_env = foldl extendInstEnv inst_env dfuns -- mkImpTypeEnv makes the imported symbol table mkImpTypeEnv :: ExternalPackageState -> HomePackageTable @@ -220,38 +154,64 @@ mkImpTypeEnv pcs hpt = lookup %************************************************************************ %* * + Initialisation +%* * +%************************************************************************ + + +\begin{code} +initTcRnIf :: Char -- Tag for unique supply + -> HscEnv + -> gbl -> lcl + -> TcRnIf gbl lcl a + -> IO a +initTcRnIf uniq_tag hsc_env gbl_env lcl_env thing_inside + = do { us <- mkSplitUniqSupply uniq_tag ; + ; us_var <- newIORef us ; + + ; let { env = Env { env_top = hsc_env, + env_us = us_var, + env_gbl = gbl_env, + env_lcl = lcl_env } } + + ; runIOEnv env thing_inside + } +\end{code} + +%************************************************************************ +%* * Simple accessors %* * %************************************************************************ \begin{code} -getTopEnv :: TcRn m TopEnv +getTopEnv :: TcRnIf gbl lcl HscEnv getTopEnv = do { env <- getEnv; return (env_top env) } -getGblEnv :: TcRn m TcGblEnv +getGblEnv :: TcRnIf gbl lcl gbl getGblEnv = do { env <- getEnv; return (env_gbl env) } -updGblEnv :: (TcGblEnv -> TcGblEnv) -> TcRn m a -> TcRn m a +updGblEnv :: (gbl -> gbl) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a updGblEnv upd = updEnv (\ env@(Env { env_gbl = gbl }) -> env { env_gbl = upd gbl }) -setGblEnv :: TcGblEnv -> TcRn m a -> TcRn m a +setGblEnv :: gbl -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a setGblEnv gbl_env = updEnv (\ env -> env { env_gbl = gbl_env }) -getLclEnv :: TcRn m m +getLclEnv :: TcRnIf gbl lcl lcl getLclEnv = do { env <- getEnv; return (env_lcl env) } -updLclEnv :: (m -> m) -> TcRn m a -> TcRn m a +updLclEnv :: (lcl -> lcl) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a updLclEnv upd = updEnv (\ env@(Env { env_lcl = lcl }) -> env { env_lcl = upd lcl }) -setLclEnv :: m -> TcRn m a -> TcRn n a +setLclEnv :: lcl' -> TcRnIf gbl lcl' a -> TcRnIf gbl lcl a setLclEnv lcl_env = updEnv (\ env -> env { env_lcl = lcl_env }) -getEnvs :: TcRn m (TcGblEnv, m) +getEnvs :: TcRnIf gbl lcl (gbl, lcl) getEnvs = do { env <- getEnv; return (env_gbl env, env_lcl env) } -setEnvs :: (TcGblEnv, m) -> TcRn m a -> TcRn m a +setEnvs :: (gbl', lcl') -> TcRnIf gbl' lcl' a -> TcRnIf gbl lcl a setEnvs (gbl_env, lcl_env) = updEnv (\ env -> env { env_gbl = gbl_env, env_lcl = lcl_env }) \end{code} @@ -259,74 +219,128 @@ setEnvs (gbl_env, lcl_env) = updEnv (\ env -> env { env_gbl = gbl_env, env_lcl = Command-line flags \begin{code} -getDOpts :: TcRn m DynFlags -getDOpts = do { env <- getTopEnv; return (top_dflags env) } +getDOpts :: TcRnIf gbl lcl DynFlags +getDOpts = do { env <- getTopEnv; return (hsc_dflags env) } -doptM :: DynFlag -> TcRn m Bool +doptM :: DynFlag -> TcRnIf gbl lcl Bool doptM flag = do { dflags <- getDOpts; return (dopt flag dflags) } -ifOptM :: DynFlag -> TcRn m () -> TcRn m () -- Do it flag is true +ifOptM :: DynFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl () -- Do it flag is true ifOptM flag thing_inside = do { b <- doptM flag; if b then thing_inside else return () } -getGhciMode :: TcRn m GhciMode -getGhciMode = do { env <- getTopEnv; return (top_mode env) } +getGhciMode :: TcRnIf gbl lcl GhciMode +getGhciMode = do { env <- getTopEnv; return (hsc_mode env) } \end{code} \begin{code} -getSrcLocM :: TcRn m SrcLoc - -- Avoid clash with Name.getSrcLoc -getSrcLocM = do { env <- getEnv; return (env_loc env) } +getEpsVar :: TcRnIf gbl lcl (TcRef ExternalPackageState) +getEpsVar = do { env <- getTopEnv; return (hsc_EPS env) } + +getEps :: TcRnIf gbl lcl ExternalPackageState +getEps = do { env <- getTopEnv; readMutVar (hsc_EPS env) } + +setEps :: ExternalPackageState -> TcRnIf gbl lcl () +setEps eps = do { env <- getTopEnv; writeMutVar (hsc_EPS env) eps } + +updateEps :: (ExternalPackageState -> (ExternalPackageState, a)) + -> TcRnIf gbl lcl a +updateEps upd_fn = do { eps_var <- getEpsVar + ; eps <- readMutVar eps_var + ; let { (eps', val) = upd_fn eps } + ; writeMutVar eps_var eps' + ; return val } + +updateEps_ :: (ExternalPackageState -> ExternalPackageState) + -> TcRnIf gbl lcl () +updateEps_ upd_fn = do { eps_var <- getEpsVar + ; updMutVar eps_var upd_fn } + +getHpt :: TcRnIf gbl lcl HomePackageTable +getHpt = do { env <- getTopEnv; return (hsc_HPT env) } +\end{code} -addSrcLoc :: SrcLoc -> TcRn m a -> TcRn m a -addSrcLoc loc = updEnv (\env -> env { env_loc = loc }) +%************************************************************************ +%* * + Unique supply +%* * +%************************************************************************ + +\begin{code} +newUnique :: TcRnIf gbl lcl Unique +newUnique = do { us <- newUniqueSupply ; + return (uniqFromSupply us) } + +newUniqueSupply :: TcRnIf gbl lcl UniqSupply +newUniqueSupply + = do { env <- getEnv ; + let { u_var = env_us env } ; + us <- readMutVar u_var ; + let { (us1, us2) = splitUniqSupply us } ; + writeMutVar u_var us1 ; + return us2 } \end{code} + +%************************************************************************ +%* * + Debugging +%* * +%************************************************************************ + \begin{code} -getEps :: TcRn m ExternalPackageState -getEps = do { env <- getTopEnv; readMutVar (top_eps env) } +traceTc, traceRn :: SDoc -> TcRn () +traceRn = dumpOptTcRn Opt_D_dump_rn_trace +traceTc = dumpOptTcRn Opt_D_dump_tc_trace +traceSplice = dumpOptTcRn Opt_D_dump_splices + + +traceIf :: SDoc -> TcRnIf m n () +traceIf = dumpOptIf Opt_D_dump_if_trace +traceHiDiffs = dumpOptIf Opt_D_dump_hi_diffs + -setEps :: ExternalPackageState -> TcRn m () -setEps eps = do { env <- getTopEnv; writeMutVar (top_eps env) eps } +dumpOptIf :: DynFlag -> SDoc -> TcRnIf m n () -- No RdrEnv available, so qualify everything +dumpOptIf flag doc = ifOptM flag $ + ioToIOEnv (printForUser stderr alwaysQualify doc) -getHpt :: TcRn m HomePackageTable -getHpt = do { env <- getTopEnv; return (top_hpt env) } +dumpOptTcRn :: DynFlag -> SDoc -> TcRn () +dumpOptTcRn flag doc = ifOptM flag (dumpTcRn doc) + +dumpTcRn :: SDoc -> TcRn () +dumpTcRn doc = do { rdr_env <- getGlobalRdrEnv ; + ioToTcRn (printForUser stderr (unQualInScope rdr_env) doc) } +\end{code} + + +%************************************************************************ +%* * + Typechecker global environment +%* * +%************************************************************************ -getModule :: TcRn m Module +\begin{code} +getModule :: TcRn Module getModule = do { env <- getGblEnv; return (tcg_mod env) } -getGlobalRdrEnv :: TcRn m GlobalRdrEnv +getGlobalRdrEnv :: TcRn GlobalRdrEnv getGlobalRdrEnv = do { env <- getGblEnv; return (tcg_rdr_env env) } -getImports :: TcRn m ImportAvails +getImports :: TcRn ImportAvails getImports = do { env <- getGblEnv; return (tcg_imports env) } -getFixityEnv :: TcRn m FixityEnv +getFixityEnv :: TcRn FixityEnv getFixityEnv = do { env <- getGblEnv; return (tcg_fix_env env) } -extendFixityEnv :: [(Name,FixitySig Name)] -> RnM a -> RnM a +extendFixityEnv :: [(Name,FixItem)] -> RnM a -> RnM a extendFixityEnv new_bit = updGblEnv (\env@(TcGblEnv { tcg_fix_env = old_fix_env }) -> env {tcg_fix_env = extendNameEnvList old_fix_env new_bit}) -getDefaultTys :: TcRn m [Type] +getDefaultTys :: TcRn (Maybe [Type]) getDefaultTys = do { env <- getGblEnv; return (tcg_default env) } \end{code} -\begin{code} -getUsageVar :: TcRn m (TcRef EntityUsage) -getUsageVar = do { env <- getGblEnv; return (tcg_usages env) } - -getUsages :: TcRn m EntityUsage -getUsages = do { usg_var <- getUsageVar; readMutVar usg_var } - -updUsages :: (EntityUsage -> EntityUsage) -> TcRn m () -updUsages upd = do { usg_var <- getUsageVar ; - usg <- readMutVar usg_var ; - writeMutVar usg_var (upd usg) } -\end{code} - - %************************************************************************ %* * Error management @@ -334,17 +348,26 @@ updUsages upd = do { usg_var <- getUsageVar ; %************************************************************************ \begin{code} -getErrsVar :: TcRn m (TcRef Messages) -getErrsVar = do { env <- getTopEnv; return (top_errs env) } +getSrcLocM :: TcRn SrcLoc + -- Avoid clash with Name.getSrcLoc +getSrcLocM = do { env <- getLclEnv; return (tcl_loc env) } + +addSrcLoc :: SrcLoc -> TcRn a -> TcRn a +addSrcLoc loc = updLclEnv (\env -> env { tcl_loc = loc }) +\end{code} -setErrsVar :: TcRef Messages -> TcRn m a -> TcRn m a -setErrsVar v = updEnv (\ env@(Env { env_top = top_env }) -> - env { env_top = top_env { top_errs = v }}) -addErr :: Message -> TcRn m () +\begin{code} +getErrsVar :: TcRn (TcRef Messages) +getErrsVar = do { env <- getLclEnv; return (tcl_errs env) } + +setErrsVar :: TcRef Messages -> TcRn a -> TcRn a +setErrsVar v = updLclEnv (\ env -> env { tcl_errs = v }) + +addErr :: Message -> TcRn () addErr msg = do { loc <- getSrcLocM ; addErrAt loc msg } -addErrAt :: SrcLoc -> Message -> TcRn m () +addErrAt :: SrcLoc -> Message -> TcRn () addErrAt loc msg = do { errs_var <- getErrsVar ; rdr_env <- getGlobalRdrEnv ; @@ -352,12 +375,12 @@ addErrAt loc msg (warns, errs) <- readMutVar errs_var ; writeMutVar errs_var (warns, errs `snocBag` err) } -addErrs :: [(SrcLoc,Message)] -> TcRn m () +addErrs :: [(SrcLoc,Message)] -> TcRn () addErrs msgs = mappM_ add msgs where add (loc,msg) = addErrAt loc msg -addWarn :: Message -> TcRn m () +addWarn :: Message -> TcRn () addWarn msg = do { errs_var <- getErrsVar ; loc <- getSrcLocM ; @@ -366,15 +389,15 @@ addWarn msg (warns, errs) <- readMutVar errs_var ; writeMutVar errs_var (warns `snocBag` warn, errs) } -checkErr :: Bool -> Message -> TcRn m () +checkErr :: Bool -> Message -> TcRn () -- Add the error if the bool is False checkErr ok msg = checkM ok (addErr msg) -warnIf :: Bool -> Message -> TcRn m () +warnIf :: Bool -> Message -> TcRn () warnIf True msg = addWarn msg warnIf False msg = return () -addMessages :: Messages -> TcRn m () +addMessages :: Messages -> TcRn () addMessages (m_warns, m_errs) = do { errs_var <- getErrsVar ; (warns, errs) <- readMutVar errs_var ; @@ -384,16 +407,16 @@ addMessages (m_warns, m_errs) \begin{code} -recoverM :: TcRn m r -- Recovery action; do this if the main one fails - -> TcRn m r -- Main action: do this first - -> TcRn m r +recoverM :: TcRn r -- Recovery action; do this if the main one fails + -> TcRn r -- Main action: do this first + -> TcRn r recoverM recover thing = do { mb_res <- try_m thing ; case mb_res of Left exn -> recover Right res -> returnM res } -tryTc :: TcRn m a -> TcRn m (Messages, Maybe a) +tryTc :: TcRn a -> TcRn (Messages, Maybe a) -- (tryTc m) executes m, and returns -- Just r, if m succeeds (returning r) and caused no errors -- Nothing, if m fails, or caused errors @@ -417,7 +440,7 @@ tryTc m | otherwise -> Just r) } -try_m :: TcRn m r -> TcRn m (Either Exception r) +try_m :: TcRn r -> TcRn (Either Exception r) -- Does try_m, with a debug-trace on failure try_m thing = do { mb_r <- tryM thing ; @@ -425,7 +448,7 @@ try_m thing Left exn -> do { traceTc (exn_msg exn); return mb_r } Right r -> return mb_r } where - exn_msg exn = text "recoverM recovering from" <+> text (showException exn) + exn_msg exn = text "tryTc/recoverM recovering from" <+> text (showException exn) tryTcLIE :: TcM a -> TcM (Messages, Maybe a) -- Just like tryTc, except that it ensures that the LIE @@ -461,7 +484,7 @@ checkNoErrs main Nothing -> failM } -ifErrsM :: TcRn m r -> TcRn m r -> TcRn m r +ifErrsM :: TcRn r -> TcRn r -> TcRn r -- ifErrsM bale_out main -- does 'bale_out' if there are errors in errors collection -- otherwise does 'main' @@ -474,108 +497,11 @@ ifErrsM bale_out normal else normal } -failIfErrsM :: TcRn m () +failIfErrsM :: TcRn () -- Useful to avoid error cascades failIfErrsM = ifErrsM failM (return ()) \end{code} -\begin{code} -forkM :: SDoc -> TcM a -> TcM (Maybe a) --- Run thing_inside in an interleaved thread. It gets a separate --- * errs_var, and --- * unique supply, --- * LIE var is set to bottom (should never be used) --- but everything else is shared, so this is DANGEROUS. --- --- It returns Nothing if the computation fails --- --- It's used for lazily type-checking interface --- signatures, which is pretty benign - -forkM doc thing_inside - = do { us <- newUniqueSupply ; - unsafeInterleaveM $ - do { us_var <- newMutVar us ; - (msgs, mb_res) <- tryTc (setLIEVar (panic "forkM: LIE used") $ - setUsVar us_var thing_inside) ; - case mb_res of - Just r -> return (Just r) - Nothing -> do { - - -- Bleat about errors in the forked thread, if -ddump-tc-trace is on - -- Otherwise we silently discard errors. Errors can legitimately - -- happen when compiling interface signatures (see tcInterfaceSigs) - ifOptM Opt_D_dump_tc_trace - (ioToTcRn (do { printErrs (hdr_doc defaultErrStyle) ; - printErrorsAndWarnings msgs })) ; - - return Nothing } - }} - where - hdr_doc = text "forkM failed:" <+> doc -\end{code} - - -%************************************************************************ -%* * - Unique supply -%* * -%************************************************************************ - -\begin{code} -getUsVar :: TcRn m (TcRef UniqSupply) -getUsVar = do { env <- getTopEnv; return (top_us env) } - -setUsVar :: TcRef UniqSupply -> TcRn m a -> TcRn m a -setUsVar v = updEnv (\ env@(Env { env_top = top_env }) -> - env { env_top = top_env { top_us = v }}) - -newUnique :: TcRn m Unique -newUnique = do { us <- newUniqueSupply ; - return (uniqFromSupply us) } - -newUniqueSupply :: TcRn m UniqSupply -newUniqueSupply - = do { u_var <- getUsVar ; - us <- readMutVar u_var ; - let { (us1, us2) = splitUniqSupply us } ; - writeMutVar u_var us1 ; - return us2 } -\end{code} - - -\begin{code} -getNameCache :: TcRn m NameCache -getNameCache = do { TopEnv { top_nc = nc_var } <- getTopEnv; - readMutVar nc_var } - -setNameCache :: NameCache -> TcRn m () -setNameCache nc = do { TopEnv { top_nc = nc_var } <- getTopEnv; - writeMutVar nc_var nc } -\end{code} - - -%************************************************************************ -%* * - Debugging -%* * -%************************************************************************ - -\begin{code} -traceTc, traceRn :: SDoc -> TcRn a () -traceRn = dumpOptTcRn Opt_D_dump_rn_trace -traceTc = dumpOptTcRn Opt_D_dump_tc_trace -traceSplice = dumpOptTcRn Opt_D_dump_splices -traceHiDiffs = dumpOptTcRn Opt_D_dump_hi_diffs - -dumpOptTcRn :: DynFlag -> SDoc -> TcRn a () -dumpOptTcRn flag doc = ifOptM flag (dumpTcRn doc) - -dumpTcRn :: SDoc -> TcRn a () -dumpTcRn doc = do { rdr_env <- getGlobalRdrEnv ; - ioToTcRn (printForUser stderr (unQualInScope rdr_env) doc) } -\end{code} - %************************************************************************ %* * @@ -780,23 +706,99 @@ incProcLevel %************************************************************************ \begin{code} -initRn :: RnMode -> RnM a -> TcRn m a -initRn mode thing_inside - = do { let { lcl_env = RnLclEnv { - rn_mode = mode, - rn_lenv = emptyRdrEnv }} ; - setLclEnv lcl_env thing_inside } -\end{code} - -\begin{code} getLocalRdrEnv :: RnM LocalRdrEnv -getLocalRdrEnv = do { env <- getLclEnv; return (rn_lenv env) } +getLocalRdrEnv = do { env <- getLclEnv; return (tcl_rdr env) } setLocalRdrEnv :: LocalRdrEnv -> RnM a -> RnM a setLocalRdrEnv rdr_env thing_inside - = updLclEnv (\env -> env {rn_lenv = rdr_env}) thing_inside - -getModeRn :: RnM RnMode -getModeRn = do { env <- getLclEnv; return (rn_mode env) } + = updLclEnv (\env -> env {tcl_rdr = rdr_env}) thing_inside \end{code} + +%************************************************************************ +%* * + Stuff for interface decls +%* * +%************************************************************************ + +\begin{code} +initIfaceTcRn :: IfG a -> TcRn a +initIfaceTcRn thing_inside + = do { tcg_env <- getGblEnv + ; let { if_env = IfGblEnv { + if_rec_types = Just (tcg_mod tcg_env, get_type_env), + if_is_boot = imp_dep_mods (tcg_imports tcg_env) } + ; get_type_env = readMutVar (tcg_type_env_var tcg_env) } + ; setEnvs (if_env, ()) thing_inside } + +initIfaceExtCore :: IfL a -> TcRn a +initIfaceExtCore thing_inside + = do { tcg_env <- getGblEnv + ; let { mod = tcg_mod tcg_env + ; if_env = IfGblEnv { + if_rec_types = Just (mod, return (tcg_type_env tcg_env)), + if_is_boot = imp_dep_mods (tcg_imports tcg_env) } + ; if_lenv = IfLclEnv { if_mod = moduleName mod, + if_tv_env = emptyOccEnv, + if_id_env = emptyOccEnv } + } + ; setEnvs (if_env, if_lenv) thing_inside } + +initIfaceIO :: HscEnv -> IfG a -> IO a +initIfaceIO hsc_env do_this + = do { let { + gbl_env = IfGblEnv { if_is_boot = emptyModuleEnv, -- Bogus? + if_rec_types = Nothing } ; + } + + -- Run the thing; any exceptions just bubble out from here + ; initTcRnIf 'i' hsc_env gbl_env () do_this + } + +initIfaceLcl :: ModuleName -> IfL a -> IfM lcl a +initIfaceLcl mod thing_inside + = setLclEnv (IfLclEnv { if_mod = mod, + if_tv_env = emptyOccEnv, + if_id_env = emptyOccEnv }) + thing_inside + + +-------------------- +forkM_maybe :: SDoc -> IfL a -> IfL (Maybe a) +-- Run thing_inside in an interleaved thread. +-- It shares everything with the parent thread, so this is DANGEROUS. +-- +-- It returns Nothing if the computation fails +-- +-- It's used for lazily type-checking interface +-- signatures, which is pretty benign + +forkM_maybe doc thing_inside + = do { unsafeInterleaveM $ + do { traceIf (text "Starting fork {" <+> doc) + ; mb_res <- tryM thing_inside ; + case mb_res of + Right r -> do { traceIf (text "} ending fork" <+> doc) + ; return (Just r) } + Left exn -> do { + + -- Bleat about errors in the forked thread, if -ddump-if-trace is on + -- Otherwise we silently discard errors. Errors can legitimately + -- happen when compiling interface signatures (see tcInterfaceSigs) + ifOptM Opt_D_dump_if_trace + (print_errs (hang (text "forkM failed:" <+> doc) + 4 (text (show exn)))) + + ; traceIf (text "} ending fork (badly)" <+> doc) + ; return Nothing } + }} + where + print_errs sdoc = ioToIOEnv (printErrs (sdoc defaultErrStyle)) + +forkM :: SDoc -> IfL a -> IfL a +forkM doc thing_inside + = do { mb_res <- forkM_maybe doc thing_inside + ; return (case mb_res of + Nothing -> pprPanic "forkM" doc + Just r -> r) } +\end{code} diff --git a/ghc/compiler/typecheck/TcRnTypes.lhs b/ghc/compiler/typecheck/TcRnTypes.lhs index 47a9ed8a58..01dbce1340 100644 --- a/ghc/compiler/typecheck/TcRnTypes.lhs +++ b/ghc/compiler/typecheck/TcRnTypes.lhs @@ -3,28 +3,21 @@ % \begin{code} module TcRnTypes( - TcRn, TcM, RnM, -- The monad is opaque outside this module + TcRnIf, TcRn, TcM, RnM, IfM, IfL, IfG, -- The monad is opaque outside this module + TcRef, - -- Standard monadic operations - thenM, thenM_, returnM, failM, - - -- Non-standard operations - runTcRn, fixM, tryM, ioToTcRn, - newMutVar, readMutVar, writeMutVar, - getEnv, setEnv, updEnv, unsafeInterleaveM, zapEnv, - -- The environment types - Env(..), TopEnv(..), TcGblEnv(..), - TcLclEnv(..), RnLclEnv(..), + Env(..), + TcGblEnv(..), TcLclEnv(..), + IfGblEnv(..), IfLclEnv(..), -- Ranamer types - RnMode(..), isInterfaceMode, isCmdLineMode, EntityUsage, emptyUsages, ErrCtxt, ImportAvails(..), emptyImportAvails, plusImportAvails, plusAvail, pruneAvails, AvailEnv, emptyAvailEnv, unitAvailEnv, plusAvailEnv, mkAvailEnv, lookupAvailEnv, lookupAvailEnv_maybe, availEnvElts, addAvail, - WhereFrom(..), + WhereFrom(..), mkModDeps, -- Typechecker types TcTyThing(..), @@ -42,25 +35,27 @@ module TcRnTypes( plusLIEs, mkLIE, isEmptyLIE, lieToList, listToLIE, -- Misc other types - TcRef, TcId, TcIdSet + TcId, TcIdSet ) where #include "HsVersions.h" import HsSyn ( PendingSplice, HsOverLit, MonoBinds, RuleDecl, ForeignDecl ) -import RnHsSyn ( RenamedHsExpr, RenamedPat, RenamedArithSeqInfo ) -import HscTypes ( GhciMode, ExternalPackageState, HomePackageTable, - NameCache, GlobalRdrEnv, LocalRdrEnv, FixityEnv, - TypeEnv, TyThing, Avails, GenAvailInfo(..), AvailInfo, - availName, IsBootInterface, Deprecations, - ExternalPackageState(..), emptyExternalPackageState ) +import RnHsSyn ( RenamedPat, RenamedArithSeqInfo ) +import HscTypes ( FixityEnv, + HscEnv, TypeEnv, TyThing, + Avails, GenAvailInfo(..), AvailInfo, + availName, IsBootInterface, Deprecations ) import Packages ( PackageName ) import TcType ( TcTyVarSet, TcType, TcTauType, TcThetaType, TcPredType, TcKind, tcCmpPred, tcCmpType, tcCmpTypes ) import InstEnv ( DFunId, InstEnv ) +import IOEnv +import RdrName ( GlobalRdrEnv, LocalRdrEnv ) import Name ( Name ) import NameEnv -import NameSet ( NameSet, emptyNameSet ) +import NameSet ( NameSet, emptyNameSet, DefUses ) +import OccName ( OccEnv ) import Type ( Type ) import Class ( Class ) import Var ( Id, TyVar ) @@ -69,29 +64,16 @@ import Module import SrcLoc ( SrcLoc ) import VarSet ( IdSet ) import ErrUtils ( Messages, Message ) -import CmdLineOpts ( DynFlags ) import UniqSupply ( UniqSupply ) import BasicTypes ( IPName ) import Util ( thenCmp ) import Bag import Outputable -import DATA_IOREF ( IORef, newIORef, readIORef, writeIORef ) -import UNSAFE_IO ( unsafeInterleaveIO ) -import FIX_IO ( fixIO ) -import EXCEPTION ( Exception(..) ) -import IO ( isUserError ) import Maybe ( mapMaybe ) import ListSetOps ( unionLists ) -import Panic ( tryJust ) \end{code} -\begin{code} -type TcRef a = IORef a -type TcId = Id -- Type may be a TcType -type TcIdSet = IdSet -\end{code} - %************************************************************************ %* * Standard monad definition for TcRn @@ -99,164 +81,22 @@ type TcIdSet = IdSet %* * %************************************************************************ -The monad itself has to be defined here, -because it is mentioned by ErrCtxt - -\begin{code} -newtype TcRn m a = TcRn (Env m -> IO a) -unTcRn (TcRn f) = f - -type TcM a = TcRn TcLclEnv a -type RnM a = TcRn RnLclEnv a - -returnM :: a -> TcRn m a -returnM a = TcRn (\ env -> return a) - -thenM :: TcRn m a -> (a -> TcRn m b) -> TcRn m b -thenM (TcRn m) f = TcRn (\ env -> do { r <- m env ; - unTcRn (f r) env }) - -thenM_ :: TcRn m a -> TcRn m b -> TcRn m b -thenM_ (TcRn m) f = TcRn (\ env -> do { m env ; unTcRn f env }) - -failM :: TcRn m a -failM = TcRn (\ env -> ioError (userError "TcRn failure")) - -instance Monad (TcRn m) where - (>>=) = thenM - (>>) = thenM_ - return = returnM - fail s = failM -- Ignore the string -\end{code} - - -%************************************************************************ -%* * - Fundmantal combinators specific to the monad -%* * -%************************************************************************ - -Running it - -\begin{code} -runTcRn :: Env m -> TcRn m a -> IO a -runTcRn env (TcRn m) = m env -\end{code} - -The fixpoint combinator - -\begin{code} -{-# NOINLINE fixM #-} - -- Aargh! Not inlining fixTc alleviates a space leak problem. - -- Normally fixTc is used with a lazy tuple match: if the optimiser is - -- shown the definition of fixTc, it occasionally transforms the code - -- in such a way that the code generator doesn't spot the selector - -- thunks. Sigh. - -fixM :: (a -> TcRn m a) -> TcRn m a -fixM f = TcRn (\ env -> fixIO (\ r -> unTcRn (f r) env)) -\end{code} - -Error recovery - -\begin{code} -tryM :: TcRn m r -> TcRn m (Either Exception r) --- Reflect exception into TcRn monad -tryM (TcRn thing) = TcRn (\ env -> tryJust tc_errors (thing env)) - where -#if __GLASGOW_HASKELL__ > 504 || __GLASGOW_HASKELL__ < 500 - tc_errors e@(IOException ioe) | isUserError ioe = Just e -#elif __GLASGOW_HASKELL__ == 502 - tc_errors e@(UserError _) = Just e -#else - tc_errors e@(IOException ioe) | isUserError e = Just e -#endif - tc_errors _other = Nothing - -- type checker failures show up as UserErrors only -\end{code} - -Lazy interleave - -\begin{code} -unsafeInterleaveM :: TcRn m a -> TcRn m a -unsafeInterleaveM (TcRn m) = TcRn (\ env -> unsafeInterleaveIO (m env)) -\end{code} - -\end{code} - -Performing arbitrary I/O, plus the read/write var (for efficiency) +The monad itself has to be defined here, because it is mentioned by ErrCtxt \begin{code} -ioToTcRn :: IO a -> TcRn m a -ioToTcRn io = TcRn (\ env -> io) - -newMutVar :: a -> TcRn m (TcRef a) -newMutVar val = TcRn (\ env -> newIORef val) - -writeMutVar :: TcRef a -> a -> TcRn m () -writeMutVar var val = TcRn (\ env -> writeIORef var val) - -readMutVar :: TcRef a -> TcRn m a -readMutVar var = TcRn (\ env -> readIORef var) -\end{code} - -Getting the environment - -\begin{code} -getEnv :: TcRn m (Env m) -{-# INLINE getEnv #-} -getEnv = TcRn (\ env -> return env) - -setEnv :: Env n -> TcRn n a -> TcRn m a -{-# INLINE setEnv #-} -setEnv new_env (TcRn m) = TcRn (\ env -> m new_env) +type TcRef a = IORef a +type TcId = Id -- Type may be a TcType +type TcIdSet = IdSet -updEnv :: (Env m -> Env n) -> TcRn n a -> TcRn m a -{-# INLINE updEnv #-} -updEnv upd (TcRn m) = TcRn (\ env -> m (upd env)) +type TcRnIf a b c = IOEnv (Env a b) c +type IfM lcl a = TcRnIf IfGblEnv lcl a -- Iface stuff +type IfG a = IfM () a -- Top level +type IfL a = IfM IfLclEnv a -- Nested +type TcRn a = TcRnIf TcGblEnv TcLclEnv a +type RnM a = TcRn a -- Historical +type TcM a = TcRn a -- Historical \end{code} -\begin{code} -zapEnv :: TcRn m a -> TcRn m a -zapEnv act = TcRn $ \env@Env{ env_top=top, env_gbl=gbl, env_lcl=lcl } -> - case top of { - TopEnv{ - top_mode = mode, - top_dflags = dflags, - top_hpt = hpt, - top_eps = eps, - top_us = us - } -> do - - eps_snap <- readIORef eps - ref <- newIORef $! emptyExternalPackageState{ eps_PTE = eps_PTE eps_snap } - - let - top' = TopEnv { - top_mode = mode, - top_dflags = dflags, - top_hpt = hpt, - top_eps = ref, - top_us = us - } - - type_env = tcg_type_env gbl - mod = tcg_mod gbl - gbl' = TcGblEnv { - tcg_mod = mod, - tcg_type_env = type_env - } - - env' = Env { - env_top = top', - env_gbl = gbl', - env_lcl = lcl - -- leave the rest empty - } - - case act of { TcRn f -> f env' } - } -\end{code} %************************************************************************ %* * @@ -265,50 +105,19 @@ zapEnv act = TcRn $ \env@Env{ env_top=top, env_gbl=gbl, env_lcl=lcl } -> %************************************************************************ \begin{code} -data Env a -- Changes as we move into an expression +data Env gbl lcl -- Changes as we move into an expression = Env { - env_top :: TopEnv, -- Top-level stuff that never changes - -- Mainly a bunch of updatable refs + env_top :: HscEnv, -- Top-level stuff that never changes -- Includes all info about imported things - env_gbl :: TcGblEnv, -- Info about things defined at the top leve - -- of the module being compiled - env_lcl :: a, -- Different for the type checker - -- and the renamer + env_us :: TcRef UniqSupply, -- Unique supply for local varibles - env_loc :: SrcLoc -- Source location - } + env_gbl :: gbl, -- Info about things defined at the top level + -- of the module being compiled -data TopEnv -- Built once at top level then does not change - -- Concerns imported stuff - -- Exceptions: error recovery points, meta computation points - = TopEnv { - top_mode :: GhciMode, - top_dflags :: DynFlags, - - -- Stuff about imports - top_eps :: TcRef ExternalPackageState, - -- PIT, ImportedModuleInfo - -- DeclsMap, IfaceRules, IfaceInsts, InstGates - -- TypeEnv, InstEnv, RuleBase - -- Mutable, because we demand-load declarations that extend the state - - top_hpt :: HomePackageTable, - -- The home package table that we've accumulated while - -- compiling the home package, - -- *excluding* the module we are compiling right now. - -- (In one-shot mode the current module is the only - -- home-package module, so tc_hpt is empty. All other - -- modules count as "external-package" modules.) - -- tc_hpt is not mutable because we only demand-load - -- external packages; the home package is eagerly - -- loaded by the compilation manager. - - -- The global name supply - top_nc :: TcRef NameCache, -- Maps original names to Names - top_us :: TcRef UniqSupply, -- Unique supply for this module - top_errs :: TcRef Messages - } + env_lcl :: lcl -- Nested stuff -- changes as we go into + -- an expression + } -- TcGblEnv describes the top-level of the module at the -- point at which the typechecker is finished work. @@ -316,12 +125,12 @@ data TopEnv -- Built once at top level then does not change data TcGblEnv = TcGblEnv { - tcg_mod :: Module, -- Module being compiled - tcg_usages :: TcRef EntityUsage, -- What version of what entities - -- have been used from other home-pkg modules + tcg_mod :: Module, -- Module being compiled tcg_rdr_env :: GlobalRdrEnv, -- Top level envt; used during renaming - tcg_fix_env :: FixityEnv, -- Ditto - tcg_default :: [Type], -- Types used for defaulting + tcg_default :: Maybe [Type], -- Types used for defaulting + -- Nothing => no 'default' decl + + tcg_fix_env :: FixityEnv, -- Just for things in this module tcg_type_env :: TypeEnv, -- Global type env for the module we are compiling now -- All TyCons and Classes (for this module) end up in here right away, @@ -329,21 +138,22 @@ data TcGblEnv -- -- (Ids defined in this module start in the local envt, -- though they move to the global envt during zonking) + + tcg_type_env_var :: TcRef TypeEnv, + -- Used only to initialise the interface-file + -- typechecker in initIfaceTcRn, so that it can see stuff + -- bound in this module when dealing with hi-boot recursions + -- Updated at intervals (e.g. after dealing with types and classes) - tcg_inst_env :: TcRef InstEnv, -- Global instance env: a combination of - -- tc_pcs, tc_hpt, *and* tc_insts - -- This field is mutable so that it can be updated inside a - -- Template Haskell splice, which might suck in some new - -- instance declarations. This is a slightly different strategy - -- than for the type envt, where we look up first in tcg_type_env - -- and then in the mutable EPS, because the InstEnv for this module - -- is constructed (in principle at least) only from the modules - -- 'below' this one, so it's this-module-specific - -- - -- On the other hand, a declaration quote [d| ... |] may introduce - -- some new instance declarations that we *don't* want to persist - -- outside the quote, so we tiresomely need to revert the InstEnv - -- after finishing the quote (see TcSplice.tcBracket) + tcg_inst_env :: InstEnv, -- Instance envt for *home-package* modules + -- Includes the dfuns in tcg_insts + tcg_inst_uses :: TcRef NameSet, -- Home-package Dfuns actually used + -- Used to generate version dependencies + -- This records usages, rather like tcg_dus, but it has to + -- be a mutable variable so it can be augmented + -- when we look up an instance. These uses of dfuns are + -- rather like the free variables of the program, but + -- are implicit instead of explicit. -- Now a bunch of things about this module that are simply -- accumulated, but never consulted until the end. @@ -353,6 +163,11 @@ data TcGblEnv tcg_imports :: ImportAvails, -- Information about what was imported -- from where, including things bound -- in this module + tcg_dus :: DefUses, -- What is defined in this module and what is used. + -- The latter is used to generate + -- (a) version tracking; no need to recompile if these + -- things have not changed version stamp + -- (b) unused-import info -- The next fields accumulate the payload of the module -- The binds, rules and foreign-decl fiels are collected @@ -365,6 +180,46 @@ data TcGblEnv } \end{code} +%************************************************************************ +%* * + The interface environments + Used when dealing with IfaceDecls +%* * +%************************************************************************ + +\begin{code} +data IfGblEnv + = IfGblEnv { + -- The type environment for the module being compiled, + -- in case the interface refers back to it via a reference that + -- was originally a hi-boot file. + -- We need the module name so we can test when it's appropriate + -- to look in this env. + if_rec_types :: Maybe (Module, IfG TypeEnv), + -- Allows a read effect, so it can be in a mutable + -- variable; c.f. handling the external package type env + -- Nothing => interactive stuff, no loops possible + + if_is_boot :: ModuleEnv (ModuleName, IsBootInterface) + -- Tells what we know about boot interface files + -- When we're importing a module we know absolutely + -- nothing about, so we assume it's from + -- another package, where we aren't doing + -- dependency tracking. So it won't be a hi-boot file. + } + +data IfLclEnv + = IfLclEnv { + -- The module for the current IfaceDecl + -- So if we see f = \x -> x + -- it means M.f = \x -> x, where M is the if_mod + if_mod :: ModuleName, + + if_tv_env :: OccEnv TyVar, -- Nested tyvar bindings + if_id_env :: OccEnv Id -- Nested id binding + } +\end{code} + %************************************************************************ %* * @@ -388,21 +243,31 @@ Why? Because they are now Ids not TcIds. This final GlobalEnv is b) used in the ModDetails of this module \begin{code} -data TcLclEnv +data TcLclEnv -- Changes as we move inside an expression + -- Discarded after typecheck/rename; not passed on to desugarer = TcLclEnv { - tcl_ctxt :: ErrCtxt, -- Error context + tcl_loc :: SrcLoc, -- Source location + tcl_ctxt :: ErrCtxt, -- Error context + tcl_errs :: TcRef Messages, -- Place to accumulate errors tcl_th_ctxt :: ThStage, -- Template Haskell context tcl_arrow_ctxt :: ArrowCtxt, -- Arrow-notation context + tcl_rdr :: LocalRdrEnv, -- Local name envt + -- Does *not* include global name envt; may shadow it + -- Includes both ordinary variables and type variables; + -- they are kept distinct because tyvar have a different + -- occurrence contructor (Name.TvOcc) + -- We still need the unsullied global name env so that + -- we can look up record field names + tcl_env :: NameEnv TcTyThing, -- The local type environment: Ids and TyVars -- defined in this module tcl_tyvars :: TcRef TcTyVarSet, -- The "global tyvars" - -- Namely, the in-scope TyVars bound in tcl_lenv, - -- plus the tyvars mentioned in the types of - -- Ids bound in tcl_lenv - -- Why mutable? see notes with tcGetGlobalTyVars + -- Namely, the in-scope TyVars bound in tcl_lenv, + -- plus the tyvars mentioned in the types of Ids bound in tcl_lenv + -- Why mutable? see notes with tcGetGlobalTyVars tcl_lie :: TcRef LIE -- Place to accumulate type constraints } @@ -476,19 +341,15 @@ data TcTyThing = AGlobal TyThing -- Used only in the return type of a lookup | ATcId TcId ThLevel ProcLevel -- Ids defined in this module; may not be fully zonked | ATyVar TyVar -- Type variables - | AThing TcKind -- Used temporarily, during kind checking --- Here's an example of how the AThing guy is used --- Suppose we are checking (forall a. T a Int): --- 1. We first bind (a -> AThink kv), where kv is a kind variable. --- 2. Then we kind-check the (T a Int) part. --- 3. Then we zonk the kind variable. --- 4. Now we know the kind for 'a', and we add (a -> ATyVar a::K) to the environment + | ARecTyCon TcKind -- Used temporarily, during kind checking, for the + | ARecClass TcKind -- tycons and clases in this recursive group instance Outputable TcTyThing where -- Debugging only - ppr (AGlobal g) = text "AGlobal" <+> ppr g - ppr (ATcId g tl pl) = text "ATcId" <+> ppr g <+> ppr tl <+> ppr pl - ppr (ATyVar t) = text "ATyVar" <+> ppr t - ppr (AThing k) = text "AThing" <+> ppr k + ppr (AGlobal g) = text "AGlobal" <+> ppr g + ppr (ATcId g tl pl) = text "ATcId" <+> ppr g <+> ppr tl <+> ppr pl + ppr (ATyVar t) = text "ATyVar" <+> ppr t + ppr (ARecTyCon k) = text "ARecTyCon" <+> ppr k + ppr (ARecClass k) = text "ARecClass" <+> ppr k \end{code} \begin{code} @@ -501,37 +362,6 @@ type ErrCtxt = [TidyEnv -> TcM (TidyEnv, Message)] %************************************************************************ %* * - The local renamer environment -%* * -%************************************************************************ - -\begin{code} -data RnLclEnv - = RnLclEnv { - rn_mode :: RnMode, - rn_lenv :: LocalRdrEnv -- Local name envt - -- Does *not* include global name envt; may shadow it - -- Includes both ordinary variables and type variables; - -- they are kept distinct because tyvar have a different - -- occurrence contructor (Name.TvOcc) - -- We still need the unsullied global name env so that - -- we can look up record field names - } - -data RnMode = SourceMode -- Renaming source code - | InterfaceMode Module -- Renaming interface declarations from M - | CmdLineMode -- Renaming a command-line expression - -isInterfaceMode (InterfaceMode _) = True -isInterfaceMode _ = False - -isCmdLineMode CmdLineMode = True -isCmdLineMode _ = False -\end{code} - - -%************************************************************************ -%* * EntityUsage %* * %************************************************************************ @@ -563,7 +393,7 @@ emptyUsages = emptyNameSet %************************************************************************ ImportAvails summarises what was imported from where, irrespective -of whether the imported htings are actually used or not +of whether the imported things are actually used or not It is used * when processing the export list * when constructing usage info for the inteface file * to identify the list of directly imported modules @@ -631,6 +461,12 @@ data ImportAvails -- Orphan modules below us in the import tree } +mkModDeps :: [(ModuleName, IsBootInterface)] + -> ModuleEnv (ModuleName, IsBootInterface) +mkModDeps deps = foldl add emptyModuleEnv deps + where + add env elt@(m,_) = extendModuleEnvByName env m elt + emptyImportAvails :: ImportAvails emptyImportAvails = ImportAvails { imp_env = emptyAvailEnv, imp_qual = emptyModuleEnv, @@ -736,17 +572,11 @@ The @WhereFrom@ type controls where the renamer looks for an interface file \begin{code} data WhereFrom = ImportByUser IsBootInterface -- Ordinary user import (perhaps {-# SOURCE #-}) - - | ImportForUsage IsBootInterface -- Import when chasing usage info from an interaface file - -- Failure in this case is not an error - | ImportBySystem -- Non user import. instance Outputable WhereFrom where ppr (ImportByUser is_boot) | is_boot = ptext SLIT("{- SOURCE -}") | otherwise = empty - ppr (ImportForUsage is_boot) | is_boot = ptext SLIT("{- USAGE SOURCE -}") - | otherwise = ptext SLIT("{- USAGE -}") ppr ImportBySystem = ptext SLIT("{- SYSTEM -}") \end{code} @@ -921,10 +751,6 @@ data InstOrigin -- translated term, and so need not be bound. Nor should they -- be abstracted over. - | CCallOrigin String -- CCall label - (Maybe RenamedHsExpr) -- Nothing if it's the result - -- Just arg, for an argument - | UnknownOrigin -- Help! I give up... \end{code} @@ -968,11 +794,6 @@ pprInstLoc (InstLoc orig locn ctxt) quotes (ppr clas), text "type:", ppr ty] pp_orig (ValSpecOrigin name) = hsep [ptext SLIT("a SPECIALIZE user-pragma for"), quotes (ppr name)] - pp_orig (CCallOrigin clabel Nothing{-ccall result-}) - = hsep [ptext SLIT("the result of the _ccall_ to"), quotes (text clabel)] - pp_orig (CCallOrigin clabel (Just arg_expr)) - = hsep [ptext SLIT("an argument in the _ccall_ to"), quotes (text clabel) <> comma, - text "namely", quotes (ppr arg_expr)] pp_orig (UnknownOrigin) = ptext SLIT("...oops -- I don't know where the overloading came from!") \end{code} diff --git a/ghc/compiler/typecheck/TcRules.lhs b/ghc/compiler/typecheck/TcRules.lhs index 0367f69689..27072a244c 100644 --- a/ghc/compiler/typecheck/TcRules.lhs +++ b/ghc/compiler/typecheck/TcRules.lhs @@ -9,17 +9,15 @@ module TcRules ( tcRules ) where #include "HsVersions.h" import HsSyn ( RuleDecl(..), RuleBndr(..), collectRuleBndrSigTys ) -import CoreSyn ( CoreRule(..) ) import RnHsSyn ( RenamedRuleDecl ) import TcHsSyn ( TypecheckedRuleDecl, mkHsLet ) import TcRnMonad import TcSimplify ( tcSimplifyToDicts, tcSimplifyInferCheck ) import TcMType ( newTyVarTy ) import TcType ( tyVarsOfTypes, openTypeKind ) -import TcIfaceSig ( tcCoreExpr, tcCoreLamBndrs ) -import TcMonoType ( tcHsSigType, UserTypeCtxt(..), tcAddScopedTyVars ) +import TcHsType ( tcHsSigType, UserTypeCtxt(..), tcAddScopedTyVars ) import TcExpr ( tcCheckRho ) -import TcEnv ( tcExtendLocalValEnv, tcLookupGlobalId, tcLookupId ) +import TcEnv ( tcExtendLocalValEnv ) import Inst ( instToId ) import Id ( idType, mkLocalId ) import Outputable @@ -30,30 +28,12 @@ tcRules :: [RenamedRuleDecl] -> TcM [TypecheckedRuleDecl] tcRules decls = mappM tcRule decls tcRule :: RenamedRuleDecl -> TcM TypecheckedRuleDecl -tcRule (IfaceRule name act vars fun args rhs src_loc) - = addSrcLoc src_loc $ - addErrCtxt (ruleCtxt name) $ - tcLookupGlobalId fun `thenM` \ fun' -> - tcCoreLamBndrs vars $ \ vars' -> - mappM tcCoreExpr args `thenM` \ args' -> - tcCoreExpr rhs `thenM` \ rhs' -> - returnM (IfaceRuleOut fun' (Rule name act vars' args' rhs')) - -tcRule (IfaceRuleOut fun rule) -- Built-in rules, and only built-in rules, - -- come this way. Usually IfaceRuleOut is only - -- used for the *output* of the type checker - = tcLookupId fun `thenM` \ fun' -> - -- NB: tcLookupId, not tcLookupGlobalId - -- Reason: when compiling GHC.Base, where eqString is defined, - -- we'll get the builtin rule for eqString, but eqString - -- will be in the *local* type environment. - -- Seems like a bit of a hack - returnM (IfaceRuleOut fun' rule) - tcRule (HsRule name act vars lhs rhs src_loc) = addSrcLoc src_loc $ addErrCtxt (ruleCtxt name) $ - newTyVarTy openTypeKind `thenM` \ rule_ty -> + traceTc (ptext SLIT("---- Rule ------") + <+> ppr name) `thenM_` + newTyVarTy openTypeKind `thenM` \ rule_ty -> -- Deal with the tyvars mentioned in signatures tcAddScopedTyVars (collectRuleBndrSigTys vars) ( diff --git a/ghc/compiler/typecheck/TcSimplify.lhs b/ghc/compiler/typecheck/TcSimplify.lhs index 1970ab387f..fb8b4bf25a 100644 --- a/ghc/compiler/typecheck/TcSimplify.lhs +++ b/ghc/compiler/typecheck/TcSimplify.lhs @@ -37,11 +37,11 @@ import Inst ( lookupInst, LookupInstResult(..), newDictsFromOld, tcInstClassOp, getDictClassTys, isTyVarDict, instLoc, zonkInst, tidyInsts, tidyMoreInsts, - Inst, pprInsts, pprInstsInFull, - isIPDict, isInheritableInst + Inst, pprInsts, pprInstsInFull, tcGetInstEnvs, + isIPDict, isInheritableInst, pprDFuns ) -import TcEnv ( tcGetGlobalTyVars, tcGetInstEnv, tcLookupId, findGlobals ) -import InstEnv ( lookupInstEnv, classInstEnv, InstLookupResult(..) ) +import TcEnv ( tcGetGlobalTyVars, tcLookupId, findGlobals ) +import InstEnv ( lookupInstEnv, classInstEnv ) import TcMType ( zonkTcTyVarsAndFV, tcInstTyVars, checkAmbiguity ) import TcType ( TcTyVar, TcTyVarSet, ThetaType, TyVarDetails(VanillaTv), mkClassPred, isOverloadedTy, mkTyConApp, @@ -54,18 +54,16 @@ import NameSet ( NameSet, mkNameSet, elemNameSet ) import Class ( classBigSig, classKey ) import FunDeps ( oclose, grow, improve, pprEquationDoc ) import PrelInfo ( isNumericClass ) -import PrelNames ( splitName, fstName, sndName, showClassKey, eqClassKey, ordClassKey) -import HscTypes ( GhciMode(Interactive) ) - +import PrelNames ( splitName, fstName, sndName, integerTyConName, + showClassKey, eqClassKey, ordClassKey ) import Subst ( mkTopTyVarSubst, substTheta, substTy ) -import TysWiredIn ( unitTy, pairTyCon ) +import TysWiredIn ( pairTyCon, doubleTy ) import ErrUtils ( Message ) import VarSet import VarEnv ( TidyEnv ) import FiniteMap import Outputable import ListSetOps ( equivClasses ) -import Unique ( hasKey ) import Util ( zipEqual, isSingleton ) import List ( partition ) import CmdLineOpts @@ -729,13 +727,18 @@ tcSimplCheck doc get_qtvs givens wanted_lie = check_loop givens wanted_lie `thenM` \ (qtvs, frees, binds, irreds) -> -- Complain about any irreducible ones - complainCheck doc givens irreds `thenM_` + mappM zonkInst given_dicts_and_ips `thenM` \ givens' -> + groupErrs (addNoInstanceErrs (Just doc) givens') irreds `thenM_` -- Done - extendLIEs frees `thenM_` + extendLIEs frees `thenM_` returnM (qtvs, binds) where + given_dicts_and_ips = filter (not . isMethod) givens + -- For error reporting, filter out methods, which are + -- only added to the given set as an optimisation + ip_set = mkNameSet (ipNamesOfInsts givens) check_loop givens wanteds @@ -1328,8 +1331,10 @@ reduceContext doc try_me givens wanteds returnM (no_improvement, frees, binds, irreds) +tcImprove :: Avails -> TcM Bool -- False <=> no change +-- Perform improvement using all the predicates in Avails tcImprove avails - = tcGetInstEnv `thenM` \ inst_env -> + = tcGetInstEnvs `thenM` \ (home_ie, pkg_ie) -> let preds = [ (pred, pp_loc) | inst <- keysFM avails, @@ -1341,7 +1346,8 @@ tcImprove avails -- It does not have duplicates (good) -- NB that (?x::t1) and (?x::t2) will be held separately in avails -- so that improve will see them separate - eqns = improve (classInstEnv inst_env) preds + eqns = improve get_insts preds + get_insts clas = classInstEnv home_ie clas ++ classInstEnv pkg_ie clas in if null eqns then returnM True @@ -1689,8 +1695,7 @@ tc_simplify_top is_interactive wanteds -- Collect together all the bad guys bad_guys = non_stds ++ concat std_bads - (tidy_env, tidy_dicts) = tidyInsts bad_guys - (bad_ips, non_ips) = partition isIPDict tidy_dicts + (bad_ips, non_ips) = partition isIPDict bad_guys (no_insts, ambigs) = partition no_inst non_ips no_inst d = not (isTyVarDict d) -- Previously, there was a more elaborate no_inst definition: @@ -1701,8 +1706,8 @@ tc_simplify_top is_interactive wanteds in -- Report definite errors - addTopInstanceErrs tidy_env no_insts `thenM_` - addTopIPErrs tidy_env bad_ips `thenM_` + groupErrs (addNoInstanceErrs Nothing []) no_insts `thenM_` + addTopIPErrs bad_ips `thenM_` -- Deal with ambiguity errors, but only if -- if there has not been an error so far; errors often @@ -1715,7 +1720,7 @@ tc_simplify_top is_interactive wanteds -- e.g. Num (IO a) and Eq (Int -> Int) -- and ambiguous dictionaries -- e.g. Num a - addTopAmbigErrs (tidy_env, ambigs) `thenM_` + addTopAmbigErrs ambigs `thenM_` -- Disambiguate the ones that look feasible mappM (disambigGroup is_interactive) std_oks @@ -1778,7 +1783,7 @@ disambigGroup is_interactive dicts -- default list which can satisfy all the ambiguous classes. -- For example, if Real a is reqd, but the only type in the -- default list is Int. - getDefaultTys `thenM` \ default_tys -> + get_default_tys `thenM` \ default_tys -> let try_default [] -- No defaults work, so fail = failM @@ -1821,8 +1826,17 @@ disambigGroup is_interactive dicts warnDefault dicts default_ty `thenM_` returnM binds - bomb_out = addTopAmbigErrs (tidyInsts dicts) `thenM_` + bomb_out = addTopAmbigErrs dicts `thenM_` returnM EmptyMonoBinds + +get_default_tys + = do { mb_defaults <- getDefaultTys + ; case mb_defaults of + Just tys -> return tys + Nothing -> -- No use-supplied default; + -- use [Integer, Double] + do { integer_ty <- tcMetaTy integerTyConName + ; return [integer_ty, doubleTy] } } \end{code} [Aside - why the defaulting mechanism is turned off when @@ -1995,28 +2009,89 @@ addInstLoc insts msg = msg $$ nest 2 (pprInstLoc (instLoc (head insts))) plural [x] = empty plural xs = char 's' - -addTopIPErrs tidy_env tidy_dicts +addTopIPErrs dicts = groupErrs report tidy_dicts where + (tidy_env, tidy_dicts) = tidyInsts dicts report dicts = addErrTcM (tidy_env, mk_msg dicts) mk_msg dicts = addInstLoc dicts (ptext SLIT("Unbound implicit parameter") <> plural tidy_dicts <+> pprInsts tidy_dicts) --- Used for top-level irreducibles -addTopInstanceErrs tidy_env tidy_dicts - = groupErrs report tidy_dicts +addNoInstanceErrs :: Maybe SDoc -- Nothing => top level + -- Just d => d describes the construct + -> [Inst] -- What is given by the context or type sig + -> [Inst] -- What is wanted + -> TcM () +addNoInstanceErrs mb_what givens [] + = returnM () +addNoInstanceErrs mb_what givens dicts + = -- Some of the dicts are here because there is no instances + -- and some because there are too many instances (overlap) + -- The first thing we do is separate them + getDOpts `thenM` \ dflags -> + tcGetInstEnvs `thenM` \ inst_envs -> + let + (tidy_env1, tidy_givens) = tidyInsts givens + (tidy_env2, tidy_dicts) = tidyMoreInsts tidy_env1 dicts + + -- Run through the dicts, generating a message for each + -- overlapping one, but simply accumulating all the + -- no-instance ones so they can be reported as a group + (overlap_doc, no_inst_dicts) = foldl check_overlap (empty, []) tidy_dicts + check_overlap (overlap_doc, no_inst_dicts) dict + | not (isClassDict dict) = (overlap_doc, dict : no_inst_dicts) + | otherwise + = case lookupInstEnv dflags inst_envs clas tys of + ([], _) -> (overlap_doc, dict : no_inst_dicts) -- No matches + inst_res -> (mk_overlap_msg dict inst_res $$ overlap_doc, no_inst_dicts) + where + (clas,tys) = getDictClassTys dict + in + mk_probable_fix tidy_env2 mb_what no_inst_dicts `thenM` \ (tidy_env3, probable_fix) -> + let + no_inst_doc | null no_inst_dicts = empty + | otherwise = vcat [addInstLoc no_inst_dicts heading, probable_fix] + heading | null givens = ptext SLIT("No instance") <> plural no_inst_dicts <+> + ptext SLIT("for") <+> pprInsts no_inst_dicts + | otherwise = sep [ptext SLIT("Could not deduce") <+> pprInsts no_inst_dicts, + nest 2 $ ptext SLIT("from the context") <+> pprInsts tidy_givens] + in + addErrTcM (tidy_env3, no_inst_doc $$ overlap_doc) + where - report dicts = mkMonomorphismMsg tidy_env dicts `thenM` \ (tidy_env, mono_msg) -> - addErrTcM (tidy_env, mk_msg dicts $$ mono_msg) - mk_msg dicts = addInstLoc dicts (ptext SLIT("No instance") <> plural tidy_dicts <+> - ptext SLIT("for") <+> pprInsts tidy_dicts) - + mk_overlap_msg dict (matches, unifiers) + = vcat [ addInstLoc [dict] ((ptext SLIT("Overlapping instances for") <+> ppr dict)), + sep [ptext SLIT("Matching instances") <> colon, + nest 2 (pprDFuns (dfuns ++ unifiers))], + if null unifiers + then empty + else parens (ptext SLIT("The choice depends on the instantiation of") <+> + quotes (pprWithCommas ppr (varSetElems (tyVarsOfInst dict))))] + where + dfuns = [df | (_, (_,_,df)) <- matches] + + mk_probable_fix tidy_env Nothing dicts -- Top level + = mkMonomorphismMsg tidy_env dicts + mk_probable_fix tidy_env (Just what) dicts -- Nested (type signatures, instance decls) + = returnM (tidy_env, sep [ptext SLIT("Probable fix:"), nest 2 fix1, nest 2 fix2]) + where + fix1 = sep [ptext SLIT("Add") <+> pprInsts dicts, + ptext SLIT("to the") <+> what] + + fix2 | null instance_dicts = empty + | otherwise = ptext SLIT("Or add an instance declaration for") + <+> pprInsts instance_dicts + instance_dicts = [d | d <- dicts, isClassDict d, not (isTyVarDict d)] + -- Insts for which it is worth suggesting an adding an instance declaration + -- Exclude implicit parameters, and tyvar dicts + -addTopAmbigErrs (tidy_env, tidy_dicts) +addTopAmbigErrs dicts -- Divide into groups that share a common set of ambiguous tyvars = mapM report (equivClasses cmp [(d, tvs_of d) | d <- tidy_dicts]) where + (tidy_env, tidy_dicts) = tidyInsts dicts + tvs_of :: Inst -> [TcTyVar] tvs_of d = varSetElems (tyVarsOfInst d) cmp (_,tvs1) (_,tvs2) = tvs1 `compare` tvs2 @@ -2066,72 +2141,6 @@ warnDefault dicts default_ty quotes (ppr default_ty), pprInstsInFull tidy_dicts] -complainCheck doc givens irreds - = mappM zonkInst given_dicts_and_ips `thenM` \ givens' -> - groupErrs (addNoInstanceErrs doc givens') irreds `thenM_` - returnM () - where - given_dicts_and_ips = filter (not . isMethod) givens - -- Filter out methods, which are only added to - -- the given set as an optimisation - -addNoInstanceErrs what_doc givens dicts - = getDOpts `thenM` \ dflags -> - tcGetInstEnv `thenM` \ inst_env -> - let - (tidy_env1, tidy_givens) = tidyInsts givens - (tidy_env2, tidy_dicts) = tidyMoreInsts tidy_env1 dicts - - doc = vcat [addInstLoc dicts $ - sep [herald <+> pprInsts tidy_dicts, - nest 4 $ ptext SLIT("from the context") <+> pprInsts tidy_givens], - ambig_doc, - ptext SLIT("Probable fix:"), - nest 4 fix1, - nest 4 fix2] - - herald = ptext SLIT("Could not") <+> unambig_doc <+> ptext SLIT("deduce") - unambig_doc | ambig_overlap = ptext SLIT("unambiguously") - | otherwise = empty - - -- The error message when we don't find a suitable instance - -- is complicated by the fact that sometimes this is because - -- there is no instance, and sometimes it's because there are - -- too many instances (overlap). See the comments in TcEnv.lhs - -- with the InstEnv stuff. - - ambig_doc - | not ambig_overlap = empty - | otherwise - = vcat [ptext SLIT("The choice of (overlapping) instance declaration"), - nest 4 (ptext SLIT("depends on the instantiation of") <+> - quotes (pprWithCommas ppr (varSetElems (tyVarsOfInsts tidy_dicts))))] - - fix1 = sep [ptext SLIT("Add") <+> pprInsts tidy_dicts, - ptext SLIT("to the") <+> what_doc] - - fix2 | null instance_dicts - = empty - | otherwise - = ptext SLIT("Or add an instance declaration for") <+> pprInsts instance_dicts - - instance_dicts = [d | d <- tidy_dicts, isClassDict d, not (isTyVarDict d)] - -- Insts for which it is worth suggesting an adding an instance declaration - -- Exclude implicit parameters, and tyvar dicts - - -- Checks for the ambiguous case when we have overlapping instances - ambig_overlap = any ambig_overlap1 dicts - ambig_overlap1 dict - | isClassDict dict - = case lookupInstEnv dflags inst_env clas tys of - NoMatch ambig -> ambig - other -> False - | otherwise = False - where - (clas,tys) = getDictClassTys dict - in - addErrTcM (tidy_env2, doc) - -- Used for the ...Thetas variants; all top level noInstErr pred = ptext SLIT("No instance for") <+> quotes (ppr pred) diff --git a/ghc/compiler/typecheck/TcSplice.lhs b/ghc/compiler/typecheck/TcSplice.lhs index 53586be63b..45d071cada 100644 --- a/ghc/compiler/typecheck/TcSplice.lhs +++ b/ghc/compiler/typecheck/TcSplice.lhs @@ -9,13 +9,13 @@ module TcSplice( tcSpliceExpr, tcSpliceDecls, tcBracket ) where #include "HsVersions.h" import HscMain ( compileExpr ) -import TcRnDriver ( importSupportingDecls, tcTopSrcDecls ) +import TcRnDriver ( tcTopSrcDecls ) -- These imports are the reason that TcSplice -- is very high up the module hierarchy import qualified Language.Haskell.THSyntax as Meta -import HscTypes ( HscEnv(..), PersistentCompilerState(..) ) +import HscTypes ( HscEnv(..) ) import HsSyn ( HsBracket(..), HsExpr(..) ) import Convert ( convertToHsExpr, convertToHsDecls ) import RnExpr ( rnExpr ) @@ -26,10 +26,9 @@ import TcHsSyn ( TcExpr, TypecheckedHsExpr, mkHsLet, zonkTopExpr ) import TcSimplify ( tcSimplifyTop, tcSimplifyBracket ) import TcUnify ( Expected, zapExpectedTo, zapExpectedType ) import TcType ( TcType, openTypeKind, mkAppTy ) -import TcEnv ( spliceOK, tcMetaTy, tcWithTempInstEnv, bracketOK ) -import TcRnTypes ( TopEnv(..) ) +import TcEnv ( spliceOK, tcMetaTy, bracketOK ) import TcMType ( newTyVarTy, UserTypeCtxt(ExprSigCtxt) ) -import TcMonoType ( tcHsSigType ) +import TcHsType ( tcHsSigType ) import Name ( Name ) import TcRnMonad @@ -109,14 +108,12 @@ tc_bracket (TypBr typ) -- Result type is Type (= Q Typ) tc_bracket (DecBr decls) - = tcWithTempInstEnv (tcTopSrcDecls decls) `thenM_` - -- Typecheck the declarations, dicarding any side effects - -- on the instance environment (which is in a mutable variable) - -- and the extended environment. We'll get all that stuff - -- later, when we splice it in - - tcMetaTy decTyConName `thenM` \ decl_ty -> - tcMetaTy qTyConName `thenM` \ q_ty -> + = tcTopSrcDecls decls `thenM_` + -- Typecheck the declarations, dicarding the result + -- We'll get all that stuff later, when we splice it in + + tcMetaTy decTyConName `thenM` \ decl_ty -> + tcMetaTy qTyConName `thenM` \ q_ty -> returnM (mkAppTy q_ty (mkListTy decl_ty)) -- Result type is Q [Dec] \end{code} @@ -186,10 +183,9 @@ tcTopSplice expr res_ty showSplice "expression" zonked_q_expr (ppr expr2) `thenM_` - initRn SourceMode (rnExpr expr2) `thenM` \ (exp3, fvs) -> - importSupportingDecls fvs `thenM` \ env -> + rnExpr expr2 `thenM` \ (exp3, fvs) -> - setGblEnv env (tcMonoExpr exp3 res_ty) + tcMonoExpr exp3 res_ty tcTopSpliceExpr :: RenamedHsExpr -> TcType -> TcM TypecheckedHsExpr @@ -265,19 +261,10 @@ runMetaD e = runMeta e runMeta :: TypecheckedHsExpr -- Of type X -> TcM t -- Of type t runMeta expr - = getTopEnv `thenM` \ top_env -> + = getTopEnv `thenM` \ hsc_env -> getGblEnv `thenM` \ tcg_env -> - getEps `thenM` \ eps -> - getNameCache `thenM` \ name_cache -> getModule `thenM` \ this_mod -> let - ghci_mode = top_mode top_env - - hsc_env = HscEnv { hsc_mode = ghci_mode, hsc_HPT = top_hpt top_env, - hsc_dflags = top_dflags top_env } - - pcs = PCS { pcs_nc = name_cache, pcs_EPS = eps } - type_env = tcg_type_env tcg_env rdr_env = tcg_rdr_env tcg_env in @@ -286,7 +273,7 @@ runMeta expr -- Running might fail if it throws an exception tryM (ioToTcRn (do hval <- HscMain.compileExpr - hsc_env pcs this_mod + hsc_env this_mod rdr_env type_env expr Meta.runQ (unsafeCoerce# hval) -- Coerce it to Q t, and run it )) `thenM` \ either_tval -> diff --git a/ghc/compiler/typecheck/TcTyClsDecls.lhs b/ghc/compiler/typecheck/TcTyClsDecls.lhs index 378dc35943..d41de58800 100644 --- a/ghc/compiler/typecheck/TcTyClsDecls.lhs +++ b/ghc/compiler/typecheck/TcTyClsDecls.lhs @@ -10,46 +10,43 @@ module TcTyClsDecls ( #include "HsVersions.h" -import HsSyn ( TyClDecl(..), - ConDecl(..), Sig(..), HsPred(..), - tyClDeclName, hsTyVarNames, tyClDeclTyVars, - isTypeOrClassDecl, isClassDecl, isSynDecl, isClassOpSig +import HsSyn ( TyClDecl(..), HsConDetails(..), HsTyVarBndr(..), + ConDecl(..), Sig(..), BangType(..), HsBang(..), + tyClDeclTyVars, getBangType, getBangStrictness ) -import RnHsSyn ( RenamedTyClDecl, tyClDeclFVs ) -import RnEnv ( lookupSysName ) -import BasicTypes ( RecFlag(..), NewOrData(..) ) +import RnHsSyn ( RenamedTyClDecl, RenamedConDecl ) +import BasicTypes ( RecFlag(..), NewOrData(..), StrictnessMark(..) ) import HscTypes ( implicitTyThings ) - +import BuildTyCl ( buildClass, buildAlgTyCon, buildSynTyCon, buildDataCon ) import TcRnMonad -import TcEnv ( TcTyThing(..), TyThing(..), TyThingDetails(..), - tcExtendKindEnv, tcLookup, tcLookupGlobal, tcExtendGlobalEnv, - isLocalThing ) -import TcTyDecls ( tcTyDecl, kcConDetails ) -import TcClassDcl ( tcClassDecl1 ) -import TcInstDcls ( tcAddDeclCtxt ) -import TcMonoType ( kcHsTyVars, kcHsType, kcHsLiftedSigType, kcHsContext, mkTyClTyVars ) -import TcMType ( newKindVar, zonkKindEnv, checkValidTyCon, checkValidClass ) +import TcEnv ( TcTyThing(..), TyThing(..), + tcLookup, tcLookupGlobal, tcExtendGlobalEnv, + tcExtendRecEnv, tcLookupTyVar ) +import TcTyDecls ( calcTyConArgVrcs, calcRecFlags, calcCycleErrs ) +import TcClassDcl ( tcClassSigs, tcAddDeclCtxt ) +import TcHsType ( kcHsTyVars, kcHsLiftedSigType, kcHsSigType, kcCheckHsType, + kcHsContext, tcTyVarBndrs, tcHsKindedType, tcHsKindedContext ) +import TcMType ( newKindVar, checkValidTheta, checkValidType, checkFreeness, + UserTypeCtxt(..), SourceTyCtxt(..), pprUserTypeCtxt ) import TcUnify ( unifyKind ) -import TcType ( Type, Kind, TcKind, mkArrowKind, liftedTypeKind, zipFunTys ) +import TcType ( TcKind, ThetaType, TcType, + mkArrowKind, liftedTypeKind, + tcSplitSigmaTy, tcEqType ) import Type ( splitTyConApp_maybe ) -import Variance ( calcTyConArgVrcs ) -import Class ( Class, mkClass, classTyCon ) -import TyCon ( TyCon, ArgVrcs, AlgTyConFlavour(..), DataConDetails(..), visibleDataCons, - tyConKind, tyConTyVars, tyConDataCons, isNewTyCon, - mkSynTyCon, mkAlgTyCon, mkClassTyCon, mkForeignTyCon - ) -import TysWiredIn ( unitTy ) -import Subst ( substTyWith ) -import DataCon ( dataConOrigArgTys ) -import Var ( varName ) -import OccName ( mkClassTyConOcc ) -import FiniteMap -import Digraph ( stronglyConnComp, SCC(..) ) -import Name ( Name ) -import NameEnv -import NameSet +import PprType ( pprThetaArrow, pprParendType ) +import FieldLabel ( fieldLabelName, fieldLabelType ) +import Generics ( validGenericMethodType, canDoGenerics ) +import Class ( Class, className, classTyCon, DefMeth(..), classBigSig ) +import TyCon ( TyCon, ArgVrcs, DataConDetails(..), + tyConDataCons, mkForeignTyCon, isProductTyCon, isRecursiveTyCon, + tyConTheta, getSynTyConDefn, tyConDataCons, isSynTyCon, tyConName ) +import DataCon ( DataCon, dataConWrapId, dataConName, dataConSig, dataConFieldLabels ) +import Var ( TyVar, idType, idName ) +import Name ( Name, getSrcLoc ) import Outputable -import Maybes ( mapMaybe, orElse, catMaybes ) +import Util ( zipLazy, isSingleton, notNull ) +import ListSetOps ( equivClasses ) +import CmdLineOpts ( DynFlag( Opt_GlasgowExts, Opt_Generics, Opt_UnboxStrictFields ) ) \end{code} @@ -59,27 +56,6 @@ import Maybes ( mapMaybe, orElse, catMaybes ) %* * %************************************************************************ -The main function -~~~~~~~~~~~~~~~~~ -\begin{code} -tcTyAndClassDecls :: [RenamedTyClDecl] - -> TcM TcGblEnv -- Returns extended environment - -tcTyAndClassDecls decls - = do { edge_map <- mkEdgeMap tc_decls ; - let { edges = mkEdges edge_map tc_decls } ; - tcGroups edge_map (stronglyConnComp edges) } - where - tc_decls = filter isTypeOrClassDecl decls - -tcGroups edge_map [] = getGblEnv - -tcGroups edge_map (group:groups) - = tcGroup edge_map group `thenM` \ env -> - setGblEnv env $ - tcGroups edge_map groups -\end{code} - Dealing with a group ~~~~~~~~~~~~~~~~~~~~ Consider a mutually-recursive group, binding @@ -124,111 +100,73 @@ The knot-tying parameters: @rec_details_list@ is an alist mapping @Name@s to @TyThing@s. @rec_vrcs@ is a finite map from @Name@s to @ArgVrcs@s. \begin{code} -tcGroup :: EdgeMap -> SCC RenamedTyClDecl - -> TcM TcGblEnv -- Input env extended by types and classes - -- and their implicit Ids,DataCons - -tcGroup edge_map scc - = -- Step 1 - mappM getInitialKind decls `thenM` \ initial_kinds -> - - -- Step 2 - tcExtendKindEnv initial_kinds (mappM kcTyClDecl decls) `thenM_` - - -- Step 3 - zonkKindEnv initial_kinds `thenM` \ final_kinds -> - - -- Check for loops; if any are found, bale out now - -- because the compiler itself will loop otherwise! - checkNoErrs (checkLoops edge_map scc) `thenM` \ is_rec_tycon -> - - -- Tie the knot - traceTc (text "starting" <+> ppr final_kinds) `thenM_` - fixM ( \ ~(rec_details_list, _, _) -> - -- Step 4 - let - kind_env = mkNameEnv final_kinds - rec_details = mkNameEnv rec_details_list - - -- Calculate variances, and feed into buildTyConOrClass - rec_vrcs = calcTyConArgVrcs [tc | ATyCon tc <- tyclss] - - build_one = buildTyConOrClass is_rec_tycon kind_env - rec_vrcs rec_details - tyclss = map build_one decls - - in - -- Step 5 - -- Extend the environment with the final - -- TyCons/Classes and check the decls - tcExtendGlobalEnv tyclss $ - mappM tcTyClDecl1 decls `thenM` \ tycls_details -> - - -- Return results - getGblEnv `thenM` \ env -> - returnM (tycls_details, env, tyclss) - ) `thenM` \ (_, env, tyclss) -> - - -- Step 7: Check validity - setGblEnv env $ - - traceTc (text "ready for validity check") `thenM_` - getModule `thenM` \ mod -> - mappM_ (checkValidTyCl mod) decls `thenM_` - traceTc (text "done") `thenM_` +tcTyAndClassDecls :: [RenamedTyClDecl] + -> TcM TcGblEnv -- Input env extended by types and classes + -- and their implicit Ids,DataCons +tcTyAndClassDecls decls + = do { -- First check for cyclic type synonysm or classes + -- See notes with checkCycleErrs + checkCycleErrs decls + + ; tyclss <- fixM (\ rec_tyclss -> + do { lcl_things <- mappM getInitialKind decls + -- Extend the local env with kinds, and + -- the global env with the knot-tied results + ; let { gbl_things = mkGlobalThings decls rec_tyclss } + ; tcExtendRecEnv gbl_things lcl_things $ do + + -- The local type environment is populated with + -- {"T" -> ARecTyCon k, ...} + -- and the global type envt with + -- {"T" -> ATyCon T, ...} + -- where k is T's (unzonked) kind + -- T is the loop-tied TyCon itself + -- We must populate the environment with the loop-tied T's right + -- away, because the kind checker may "fault in" some type + -- constructors that recursively mention T + + -- Kind-check the declarations, returning kind-annotated decls + { kc_decls <- mappM kcTyClDecl decls + + -- Calculate variances and rec-flag + ; let { calc_vrcs = calcTyConArgVrcs rec_tyclss + ; calc_rec = calcRecFlags rec_tyclss } + + ; mappM (tcTyClDecl calc_vrcs calc_rec) kc_decls + }}) + -- Finished with knot-tying now + -- Extend the environment with the finished things + ; tcExtendGlobalEnv tyclss $ do + + -- Perform the validity check + { traceTc (text "ready for validity check") + ; mappM_ checkValidTyCl decls + ; traceTc (text "done") - let -- Add the tycons that come from the classes - -- We want them in the environment because - -- they are mentioned in interface files - implicit_things = implicitTyThings tyclss - in - traceTc ((text "Adding" <+> ppr tyclss) $$ (text "and" <+> ppr implicit_things)) `thenM_` - tcExtendGlobalEnv implicit_things getGblEnv - + -- Add the implicit things; + -- we want them in the environment because + -- they may be mentioned in interface files + ; let { implicit_things = concatMap implicitTyThings tyclss } + ; traceTc ((text "Adding" <+> ppr tyclss) $$ (text "and" <+> ppr implicit_things)) + ; tcExtendGlobalEnv implicit_things getGblEnv + }} + +mkGlobalThings :: [RenamedTyClDecl] -- The decls + -> [TyThing] -- Knot-tied, in 1-1 correspondence with the decls + -> [(Name,TyThing)] +-- Driven by the Decls, and treating the TyThings lazily +-- make a TypeEnv for the new things +mkGlobalThings decls things + = map mk_thing (decls `zipLazy` things) where - decls = case scc of - AcyclicSCC decl -> [decl] - CyclicSCC decls -> decls - -tcTyClDecl1 decl - | isClassDecl decl = tcAddDeclCtxt decl (tcClassDecl1 decl) - | otherwise = tcAddDeclCtxt decl (tcTyDecl decl) - --- We do the validity check over declarations, rather than TyThings --- only so that we can add a nice context with tcAddDeclCtxt -checkValidTyCl this_mod decl - = tcLookupGlobal (tcdName decl) `thenM` \ thing -> - if not (isLocalThing this_mod thing) then - -- Don't bother to check validity for non-local things - returnM () - else - tcAddDeclCtxt decl $ - case thing of - ATyCon tc -> checkValidTyCon tc - AClass cl -> checkValidClass cl -\end{code} - - -%************************************************************************ -%* * -\subsection{Step 1: Initial environment} -%* * -%************************************************************************ - -\begin{code} -getInitialKind :: RenamedTyClDecl -> TcM (Name, TcKind) -getInitialKind decl - = kcHsTyVars (tyClDeclTyVars decl) `thenM` \ arg_kinds -> - newKindVar `thenM` \ result_kind -> - returnM (tcdName decl, mk_kind arg_kinds result_kind) - -mk_kind tvs_w_kinds res_kind = foldr (mkArrowKind . snd) res_kind tvs_w_kinds + mk_thing (ClassDecl {tcdName = name}, ~(AClass cl)) = (name, AClass cl) + mk_thing (decl, ~(ATyCon tc)) = (tcdName decl, ATyCon tc) \end{code} %************************************************************************ %* * -\subsection{Step 2: Kind checking} + Kind checking %* * %************************************************************************ @@ -246,190 +184,214 @@ depends on *all the uses of class D*. For example, the use of Monad c in bop's type signature means that D must have kind Type->Type. \begin{code} -kcTyClDecl :: RenamedTyClDecl -> TcM () +------------------------------------------------------------------------ +getInitialKind :: TyClDecl Name -> TcM (Name, TcTyThing) -kcTyClDecl decl@(TySynonym {tcdSynRhs = rhs}) - = kcTyClDeclBody decl $ \ result_kind -> - kcHsType rhs `thenM` \ rhs_kind -> - unifyKind result_kind rhs_kind +-- Note the lazy pattern match on the ATyCon etc +-- Exactly the same reason as the zipLay above + +getInitialKind (TyData {tcdName = name}) + = newKindVar `thenM` \ kind -> + returnM (name, ARecTyCon kind) + +getInitialKind (TySynonym {tcdName = name}) + = newKindVar `thenM` \ kind -> + returnM (name, ARecTyCon kind) + +getInitialKind (ClassDecl {tcdName = name}) + = newKindVar `thenM` \ kind -> + returnM (name, ARecClass kind) -kcTyClDecl (ForeignType {}) = returnM () -kcTyClDecl decl@(TyData {tcdND = new_or_data, tcdCtxt = context, tcdCons = con_decls}) - = kcTyClDeclBody decl $ \ result_kind -> - kcHsContext context `thenM_` - mappM_ kc_con_decl (visibleDataCons con_decls) +------------------------------------------------------------------------ +kcTyClDecl :: RenamedTyClDecl -> TcM RenamedTyClDecl + +kcTyClDecl decl@(TySynonym {tcdSynRhs = rhs}) + = do { res_kind <- newKindVar + ; kcTyClDeclBody decl res_kind $ \ tvs' -> + do { rhs' <- kcCheckHsType rhs res_kind + ; return (decl {tcdTyVars = tvs', tcdSynRhs = rhs'}) } } + +kcTyClDecl decl@(TyData {tcdND = new_or_data, tcdCtxt = ctxt, tcdCons = cons}) + = kcTyClDeclBody decl liftedTypeKind $ \ tvs' -> + do { ctxt' <- kcHsContext ctxt + ; cons' <- mappM kc_con_decl cons + ; return (decl {tcdTyVars = tvs', tcdCtxt = ctxt', tcdCons = cons'}) } where - kc_con_decl (ConDecl _ ex_tvs ex_ctxt details loc) - = kcHsTyVars ex_tvs `thenM` \ kind_env -> - tcExtendKindEnv kind_env $ - kcConDetails new_or_data ex_ctxt details - -kcTyClDecl decl@(ClassDecl {tcdCtxt = context, tcdSigs = class_sigs}) - = kcTyClDeclBody decl $ \ result_kind -> - kcHsContext context `thenM_` - mappM_ kc_sig (filter isClassOpSig class_sigs) + kc_con_decl (ConDecl name ex_tvs ex_ctxt details loc) + = kcHsTyVars ex_tvs $ \ ex_tvs' -> + do { ex_ctxt' <- kcHsContext ex_ctxt + ; details' <- kc_con_details details + ; return (ConDecl name ex_tvs' ex_ctxt' details' loc)} + + kc_con_details (PrefixCon btys) + = do { btys' <- mappM kc_arg_ty btys ; return (PrefixCon btys') } + kc_con_details (InfixCon bty1 bty2) + = do { bty1' <- kc_arg_ty bty1; bty2' <- kc_arg_ty bty2; return (InfixCon bty1' bty2') } + kc_con_details (RecCon fields) + = do { fields' <- mappM kc_field fields; return (RecCon fields') } + + kc_field (fld, bty) = do { bty' <- kc_arg_ty bty ; return (fld, bty') } + + kc_arg_ty (BangType str ty) = do { ty' <- kc_arg_ty_body ty; return (BangType str ty') } + kc_arg_ty_body = case new_or_data of + DataType -> kcHsSigType + NewType -> kcHsLiftedSigType + -- Can't allow an unlifted type for newtypes, because we're effectively + -- going to remove the constructor while coercing it to a lifted type. + +kcTyClDecl decl@(ClassDecl {tcdCtxt = ctxt, tcdSigs = sigs}) + = kcTyClDeclBody decl liftedTypeKind $ \ tvs' -> + do { ctxt' <- kcHsContext ctxt + ; sigs' <- mappM kc_sig sigs + ; return (decl {tcdTyVars = tvs', tcdCtxt = ctxt', tcdSigs = sigs'}) } where - kc_sig (ClassOpSig _ _ op_ty loc) = kcHsLiftedSigType op_ty - -kcTyClDeclBody :: RenamedTyClDecl -> (Kind -> TcM a) -> TcM a --- Extend the env with bindings for the tyvars, taken from --- the kind of the tycon/class. Give it to the thing inside, and --- check the result kind matches -kcTyClDeclBody decl thing_inside + kc_sig (Sig nm op_ty loc) = do { op_ty' <- kcHsLiftedSigType op_ty + ; return (Sig nm op_ty' loc) } + kc_sig other_sig = return other_sig + +kcTyClDecl decl@(ForeignType {}) + = return decl + +kcTyClDeclBody :: RenamedTyClDecl -> TcKind + -> ([HsTyVarBndr Name] -> TcM a) + -> TcM a + -- Extend the env with bindings for the tyvars, taken from + -- the kind of the tycon/class. Give it to the thing inside, and + -- check the result kind matches +kcTyClDeclBody decl res_kind thing_inside = tcAddDeclCtxt decl $ - tcLookup (tcdName decl) `thenM` \ thing -> - let - kind = case thing of - AGlobal (ATyCon tc) -> tyConKind tc - AGlobal (AClass cl) -> tyConKind (classTyCon cl) - AThing kind -> kind - -- For some odd reason, a class doesn't include its kind - - (tyvars_w_kinds, result_kind) = zipFunTys (hsTyVarNames (tyClDeclTyVars decl)) kind - in - tcExtendKindEnv tyvars_w_kinds (thing_inside result_kind) + kcHsTyVars (tyClDeclTyVars decl) $ \ kinded_tvs -> + do { tc_ty_thing <- tcLookup (tcdName decl) + ; let { tc_kind = case tc_ty_thing of + ARecClass k -> k + ARecTyCon k -> k + } + ; unifyKind tc_kind (foldr (mkArrowKind . kindedTyVarKind) + res_kind kinded_tvs) + ; thing_inside kinded_tvs } + +kindedTyVarKind (KindedTyVar _ k) = k \end{code} - %************************************************************************ %* * -\subsection{Step 4: Building the tycon/class} +\subsection{Type checking} %* * %************************************************************************ \begin{code} -buildTyConOrClass - :: (Name -> AlgTyConFlavour -> RecFlag) -- Whether it's recursive - -> NameEnv Kind - -> FiniteMap TyCon ArgVrcs -> NameEnv TyThingDetails - -> RenamedTyClDecl -> TyThing - -buildTyConOrClass rec_tycon kenv rec_vrcs rec_details - (TySynonym {tcdName = tycon_name, tcdTyVars = tyvar_names}) - = ATyCon tycon +tcTyClDecl :: (Name -> ArgVrcs) -> (Name -> RecFlag) + -> RenamedTyClDecl -> TcM TyThing + +tcTyClDecl calc_vrcs calc_isrec decl + = tcAddDeclCtxt decl (tcTyClDecl1 calc_vrcs calc_isrec decl) + +tcTyClDecl1 calc_vrcs calc_isrec + (TySynonym {tcdName = tc_name, tcdTyVars = tvs, tcdSynRhs = rhs_ty}) + = tcTyVarBndrs tvs $ \ tvs' -> do + { rhs_ty' <- tcHsKindedType rhs_ty + ; return (ATyCon (buildSynTyCon tc_name tvs' rhs_ty' arg_vrcs)) } where - tycon = mkSynTyCon tycon_name tycon_kind arity tyvars rhs_ty argvrcs - tycon_kind = lookupNameEnv_NF kenv tycon_name - arity = length tyvar_names - tyvars = mkTyClTyVars tycon_kind tyvar_names - SynTyDetails rhs_ty = lookupNameEnv_NF rec_details tycon_name - argvrcs = lookupWithDefaultFM rec_vrcs bogusVrcs tycon - -buildTyConOrClass rec_tycon kenv rec_vrcs rec_details - (TyData {tcdND = data_or_new, tcdName = tycon_name, - tcdTyVars = tyvar_names}) - = ATyCon tycon + arg_vrcs = calc_vrcs tc_name + +tcTyClDecl1 calc_vrcs calc_isrec + (TyData {tcdND = new_or_data, tcdCtxt = ctxt, tcdTyVars = tvs, + tcdName = tc_name, tcdCons = cons}) + = tcTyVarBndrs tvs $ \ tvs' -> do + { ctxt' <- tcHsKindedContext ctxt + ; want_generic <- doptM Opt_Generics + ; tycon <- fixM (\ tycon -> do + { cons' <- mappM (tcConDecl new_or_data tycon tvs' ctxt') cons + ; buildAlgTyCon new_or_data tc_name tvs' ctxt' + (DataCons cons') arg_vrcs is_rec + (want_generic && canDoGenerics cons') + }) + ; return (ATyCon tycon) + } where - tycon = mkAlgTyCon tycon_name tycon_kind tyvars ctxt argvrcs - data_cons sel_ids flavour - (rec_tycon tycon_name flavour) gen_info - - DataTyDetails ctxt data_cons sel_ids gen_info = lookupNameEnv_NF rec_details tycon_name - - tycon_kind = lookupNameEnv_NF kenv tycon_name - tyvars = mkTyClTyVars tycon_kind tyvar_names - argvrcs = lookupWithDefaultFM rec_vrcs bogusVrcs tycon - - -- Watch out! mkTyConApp asks whether the tycon is a NewType, - -- so flavour has to be able to answer this question without consulting rec_details - flavour = case data_or_new of - NewType -> NewTyCon (mkNewTyConRep tycon) - DataType | all_nullary data_cons -> EnumTyCon - | otherwise -> DataTyCon - - all_nullary (DataCons cons) = all (null . dataConOrigArgTys) cons - all_nullary other = False -- Safe choice for unknown data types - -- NB (null . dataConOrigArgTys). It used to say isNullaryDataCon - -- but that looks at the *representation* arity, and that in turn - -- depends on deciding whether to unpack the args, and that - -- depends on whether it's a data type or a newtype --- so - -- in the recursive case we can get a loop. This version is simple! - -buildTyConOrClass rec_tycon kenv rec_vrcs rec_details - (ForeignType {tcdName = tycon_name, tcdExtName = tycon_ext_name}) - = ATyCon (mkForeignTyCon tycon_name tycon_ext_name liftedTypeKind 0 []) - -buildTyConOrClass rec_tycon kenv rec_vrcs rec_details - (ClassDecl {tcdName = class_name, tcdTyVars = tyvar_names, tcdFDs = fundeps} ) - = AClass clas + arg_vrcs = calc_vrcs tc_name + is_rec = calc_isrec tc_name + +tcTyClDecl1 calc_vrcs calc_isrec + (ClassDecl {tcdName = class_name, tcdTyVars = tvs, + tcdCtxt = ctxt, tcdMeths = meths, + tcdFDs = fundeps, tcdSigs = sigs} ) + = tcTyVarBndrs tvs $ \ tvs' -> do + { ctxt' <- tcHsKindedContext ctxt + ; fds' <- mappM tc_fundep fundeps + ; sig_stuff <- tcClassSigs class_name sigs meths + ; clas <- fixM (\ clas -> + let -- This little knot is just so we can get + -- hold of the name of the class TyCon, which we + -- need to look up its recursiveness and variance + tycon_name = tyConName (classTyCon clas) + tc_isrec = calc_isrec tycon_name + tc_vrcs = calc_vrcs tycon_name + in + buildClass class_name tvs' ctxt' fds' + sig_stuff tc_isrec tc_vrcs) + ; return (AClass clas) } where - clas = mkClass class_name tyvars fds - sc_theta sc_sel_ids op_items - tycon - - tycon = mkClassTyCon tycon_name class_kind tyvars - argvrcs dict_con - clas -- Yes! It's a dictionary - flavour - (rec_tycon class_name flavour) - -- A class can be recursive, and in the case of newtypes - -- this matters. For example - -- class C a where { op :: C b => a -> b -> Int } - -- Because C has only one operation, it is represented by - -- a newtype, and it should be a *recursive* newtype. - -- [If we don't make it a recursive newtype, we'll expand the - -- newtype like a synonym, but that will lead toan inifinite type - - ClassDetails sc_theta sc_sel_ids op_items dict_con tycon_name - = lookupNameEnv_NF rec_details class_name - - class_kind = lookupNameEnv_NF kenv class_name - tyvars = mkTyClTyVars class_kind tyvar_names - argvrcs = lookupWithDefaultFM rec_vrcs bogusVrcs tycon - - flavour = case dataConOrigArgTys dict_con of - -- The tyvars in the datacon are the same as in the class - [rep_ty] -> NewTyCon rep_ty - other -> DataTyCon - - -- We can find the functional dependencies right away, - -- and it is vital to do so. Why? Because in the next pass - -- we check for ambiguity in all the type signatures, and we - -- need the functional dependcies to be done by then - fds = [(map lookup xs, map lookup ys) | (xs,ys) <- fundeps] - tyvar_env = mkNameEnv [(varName tv, tv) | tv <- tyvars] - lookup = lookupNameEnv_NF tyvar_env - -bogusVrcs = panic "Bogus tycon arg variances" -\end{code} - -\begin{code} -mkNewTyConRep :: TyCon -- The original type constructor - -> Type -- Chosen representation type - -- (guaranteed not to be another newtype) - --- Find the representation type for this newtype TyCon --- Remember that the representation type is the ultimate representation --- type, looking through other newtypes. --- --- The non-recursive newtypes are easy, because they look transparent --- to splitTyConApp_maybe, but recursive ones really are represented as --- TyConApps (see TypeRep). --- --- The trick is to to deal correctly with recursive newtypes --- such as newtype T = MkT T - --- a newtype with no data constructors -- appears in External Core programs -mkNewTyConRep tc | (null (tyConDataCons tc)) = unitTy -mkNewTyConRep tc - = go [] tc + tc_fundep (tvs1, tvs2) = do { tvs1' <- mappM tcLookupTyVar tvs1 ; + ; tvs2' <- mappM tcLookupTyVar tvs2 ; + ; return (tvs1', tvs2') } + + +tcTyClDecl1 calc_vrcs calc_isrec + (ForeignType {tcdName = tc_name, tcdExtName = tc_ext_name}) + = returnM (ATyCon (mkForeignTyCon tc_name tc_ext_name liftedTypeKind 0 [])) + +----------------------------------- +tcConDecl :: NewOrData -> TyCon -> [TyVar] -> ThetaType + -> RenamedConDecl -> TcM DataCon + +tcConDecl new_or_data tycon tyvars ctxt + (ConDecl name ex_tvs ex_ctxt details src_loc) + = addSrcLoc src_loc $ + tcTyVarBndrs ex_tvs $ \ ex_tvs' -> do + { ex_ctxt' <- tcHsKindedContext ex_ctxt + ; unbox_strict <- doptM Opt_UnboxStrictFields + ; let + tc_datacon field_lbls btys + = do { arg_tys <- mappM (tcHsKindedType . getBangType) btys + ; buildDataCon name + (argStrictness unbox_strict tycon btys arg_tys) + field_lbls + tyvars ctxt ex_tvs' ex_ctxt' + arg_tys tycon } + ; case details of + PrefixCon btys -> tc_datacon [] btys + InfixCon bty1 bty2 -> tc_datacon [] [bty1,bty2] + RecCon fields -> do { checkTc (null ex_tvs') (exRecConErr name) + ; let { (field_names, btys) = unzip fields } + ; tc_datacon field_names btys } } + +argStrictness :: Bool -- True <=> -funbox-strict_fields + -> TyCon -> [BangType Name] + -> [TcType] -> [StrictnessMark] +argStrictness unbox_strict tycon btys arg_tys + = zipWith (chooseBoxingStrategy unbox_strict tycon) + arg_tys + (map getBangStrictness btys ++ repeat HsNoBang) + +-- We attempt to unbox/unpack a strict field when either: +-- (i) The field is marked '!!', or +-- (ii) The field is marked '!', and the -funbox-strict-fields flag is on. + +chooseBoxingStrategy :: Bool -> TyCon -> TcType -> HsBang -> StrictnessMark +chooseBoxingStrategy unbox_strict_fields tycon arg_ty bang + = case bang of + HsNoBang -> NotMarkedStrict + HsStrict | unbox_strict_fields && can_unbox -> MarkedUnboxed + HsUnbox | can_unbox -> MarkedUnboxed + other -> MarkedStrict where - -- Invariant: tc is a NewTyCon - -- tcs have been seen before - go tcs tc - | tc `elem` tcs = unitTy - | otherwise - = let - rep_ty = head (dataConOrigArgTys (head (tyConDataCons tc))) - in - case splitTyConApp_maybe rep_ty of - Nothing -> rep_ty - Just (tc', tys) | not (isNewTyCon tc') -> rep_ty - | otherwise -> go1 (tc:tcs) tc' tys - - go1 tcs tc tys = substTyWith (tyConTyVars tc) tys (go tcs tc) + can_unbox = case splitTyConApp_maybe arg_ty of + Nothing -> False + Just (arg_tycon, _) -> not (isRecursiveTyCon tycon) && + isProductTyCon arg_tycon \end{code} %************************************************************************ @@ -438,129 +400,204 @@ mkNewTyConRep tc %* * %************************************************************************ -Dependency analysis -~~~~~~~~~~~~~~~~~~~ +Validity checking is done once the mutually-recursive knot has been +tied, so we can look at things freely. + \begin{code} -checkLoops :: EdgeMap -> SCC RenamedTyClDecl - -> TcM (Name -> AlgTyConFlavour -> RecFlag) --- Check for illegal loops in a single strongly-connected component --- a) type synonyms --- b) superclass hierarchy --- --- Also return a function that says which tycons are recursive. --- Remember: --- a newtype is recursive if it is part of a recursive --- group consisting only of newtype and synonyms - -checkLoops edge_map (AcyclicSCC _) - = returnM (\ _ _ -> NonRecursive) - -checkLoops edge_map (CyclicSCC decls) - = let -- CHECK FOR CLASS CYCLES - cls_edges = mapMaybe mkClassEdges decls - cls_cycles = findCycles cls_edges - in - mapM_ (cycleErr "class") cls_cycles `thenM_` - - let -- CHECK FOR SYNONYM CYCLES - syn_edges = mkEdges edge_map (filter isSynDecl decls) - syn_cycles = findCycles syn_edges - in - mapM_ (cycleErr "type synonym") syn_cycles `thenM_` - - let -- CHECK FOR NEWTYPE CYCLES - newtype_edges = mkEdges edge_map (filter is_nt_cycle_decl decls) - newtype_cycles = findCycles newtype_edges - rec_newtypes = mkNameSet [tcdName d | ds <- newtype_cycles, d <- ds] - - rec_tycon name (NewTyCon _) - | name `elemNameSet` rec_newtypes = Recursive - | otherwise = NonRecursive - rec_tycon name other_flavour = Recursive - in - returnM rec_tycon - ----------------------------------------------------- --- A class with one op and no superclasses, or vice versa, --- is treated just like a newtype. --- It's a bit unclean that this test is repeated in buildTyConOrClass -is_nt_cycle_decl (TySynonym {}) = True -is_nt_cycle_decl (TyData {tcdND = NewType}) = True -is_nt_cycle_decl (ClassDecl {tcdCtxt = ctxt, tcdSigs = sigs}) = length ctxt + length sigs == 1 -is_nt_cycle_decl other = False - ----------------------------------------------------- -findCycles edges = [ ds | CyclicSCC ds <- stronglyConnComp edges] - ----------------------------------------------------- --- Building edges for SCC analysis --- --- When building the edges, we treat the 'main name' of the declaration as the --- key for the node, but when dealing with External Core we may come across --- references to one of the implicit names for the declaration. For example: --- class Eq a where .... --- data :TSig a = :TSig (:TEq a) .... --- The first decl is sucked in from an interface file; the second --- is in an External Core file, generated from a class decl for Sig. --- We have to recognise that the reference to :TEq represents a --- dependency on the class Eq declaration, else the SCC stuff won't work right. --- --- This complication can only happen when consuming an External Core file --- --- Solution: keep an "EdgeMap" (bad name) that maps :TEq -> Eq. --- Don't worry about data constructors, because we're only building --- SCCs for type and class declarations here. So the tiresome mapping --- is need only to map [class tycon -> class] - -type EdgeMap = NameEnv Name - -mkEdgeMap :: [RenamedTyClDecl] -> TcM EdgeMap -mkEdgeMap decls = do { mb_pairs <- mapM mk_mb_pair decls ; - return (mkNameEnv (catMaybes mb_pairs)) } - where - mk_mb_pair (ClassDecl { tcdName = cls_name }) - = do { tc_name <- lookupSysName cls_name mkClassTyConOcc ; - return (Just (tc_name, cls_name)) } - mk_mb_pair other = return Nothing - -mkEdges :: EdgeMap -> [RenamedTyClDecl] -> [(RenamedTyClDecl, Name, [Name])] --- We use the EdgeMap to map any implicit names to --- the 'main name' for the declaration -mkEdges edge_map decls - = [ (decl, tyClDeclName decl, get_refs decl) | decl <- decls ] +checkCycleErrs :: [TyClDecl Name] -> TcM () +checkCycleErrs tyclss + | null syn_cycles && null cls_cycles + = return () + | otherwise + = do { mappM_ recSynErr syn_cycles + ; mappM_ recClsErr cls_cycles + ; failM } -- Give up now, because later checkValidTyCl + -- will loop if the synonym is recursive where - get_refs decl = [ lookupNameEnv edge_map n `orElse` n - | n <- nameSetToList (tyClDeclFVs decl) ] + (syn_cycles, cls_cycles) = calcCycleErrs tyclss ----------------------------------------------------- --- mk_cls_edges looks only at the context of class decls --- Its used when we are figuring out if there's a cycle in the --- superclass hierarchy +checkValidTyCl :: RenamedTyClDecl -> TcM () +-- We do the validity check over declarations, rather than TyThings +-- only so that we can add a nice context with tcAddDeclCtxt +checkValidTyCl decl + = tcAddDeclCtxt decl $ + do { thing <- tcLookupGlobal (tcdName decl) + ; traceTc (text "Validity of" <+> ppr thing) + ; case thing of + ATyCon tc -> checkValidTyCon tc + AClass cl -> checkValidClass cl + ; traceTc (text "Done validity of" <+> ppr thing) + } + +------------------------- +checkValidTyCon :: TyCon -> TcM () +checkValidTyCon tc + | isSynTyCon tc + = addErrCtxt (checkTypeCtxt syn_ctxt syn_rhs) $ + checkValidType syn_ctxt syn_rhs + | otherwise + = -- Check the context on the data decl + checkValidTheta (DataTyCtxt name) (tyConTheta tc) `thenM_` + + -- Check arg types of data constructors + mappM_ checkValidDataCon data_cons `thenM_` -mkClassEdges :: RenamedTyClDecl -> Maybe (RenamedTyClDecl, Name, [Name]) -mkClassEdges decl@(ClassDecl {tcdCtxt = ctxt, tcdName = name}) = Just (decl, name, [c | HsClassP c _ <- ctxt]) -mkClassEdges other_decl = Nothing -\end{code} + -- Check that fields with the same name share a type + mappM_ check_fields groups + where + syn_ctxt = TySynCtxt name + name = tyConName tc + (_, syn_rhs) = getSynTyConDefn tc + data_cons = tyConDataCons tc + + fields = [field | con <- data_cons, field <- dataConFieldLabels con] + groups = equivClasses cmp_name fields + cmp_name field1 field2 = fieldLabelName field1 `compare` fieldLabelName field2 + + check_fields fields@(first_field_label : other_fields) + -- These fields all have the same name, but are from + -- different constructors in the data type + = -- Check that all the fields in the group have the same type + -- NB: this check assumes that all the constructors of a given + -- data type use the same type variables + checkTc (all (tcEqType field_ty) other_tys) (fieldTypeMisMatch field_name) + where + field_ty = fieldLabelType first_field_label + field_name = fieldLabelName first_field_label + other_tys = map fieldLabelType other_fields + +------------------------------- +checkValidDataCon :: DataCon -> TcM () +checkValidDataCon con + = addErrCtxt (dataConCtxt con) ( + checkValidType ctxt (idType (dataConWrapId con)) `thenM_` + -- This checks the argument types and + -- ambiguity of the existential context (if any) + checkFreeness ex_tvs ex_theta) + where + ctxt = ConArgCtxt (dataConName con) + (_, _, ex_tvs, ex_theta, _, _) = dataConSig con -%************************************************************************ -%* * -\subsection{Error management -%* * -%************************************************************************ -\begin{code} -cycleErr :: String -> [RenamedTyClDecl] -> TcM () +------------------------------- +checkValidClass :: Class -> TcM () +checkValidClass cls + = do { -- CHECK ARITY 1 FOR HASKELL 1.4 + gla_exts <- doptM Opt_GlasgowExts + + -- Check that the class is unary, unless GlaExs + ; checkTc (notNull tyvars) (nullaryClassErr cls) + ; checkTc (gla_exts || unary) (classArityErr cls) + + -- Check the super-classes + ; checkValidTheta (ClassSCCtxt (className cls)) theta + + -- Check the class operations + ; mappM_ check_op op_stuff -cycleErr kind_of_decl decls - = addErrAt loc (ppr_cycle kind_of_decl decls) + -- Check that if the class has generic methods, then the + -- class has only one parameter. We can't do generic + -- multi-parameter type classes! + ; checkTc (unary || no_generics) (genericMultiParamErr cls) + } where - loc = tcdLoc (head decls) + (tyvars, theta, _, op_stuff) = classBigSig cls + unary = isSingleton tyvars + no_generics = null [() | (_, GenDefMeth) <- op_stuff] -ppr_cycle kind_of_decl decls - = hang (ptext SLIT("Cycle in") <+> text kind_of_decl <+> ptext SLIT("declarations:")) - 4 (vcat (map pp_decl decls)) + check_op (sel_id, dm) + = addErrCtxt (classOpCtxt sel_id) ( + checkValidTheta SigmaCtxt (tail theta) `thenM_` + -- The 'tail' removes the initial (C a) from the + -- class itself, leaving just the method type + + checkValidType (FunSigCtxt op_name) tau `thenM_` + + -- Check that for a generic method, the type of + -- the method is sufficiently simple + checkTc (dm /= GenDefMeth || validGenericMethodType op_ty) + (badGenericMethodType op_name op_ty) + ) + where + op_name = idName sel_id + op_ty = idType sel_id + (_,theta,tau) = tcSplitSigmaTy op_ty + + + +--------------------------------------------------------------------- +fieldTypeMisMatch field_name + = sep [ptext SLIT("Different constructors give different types for field"), quotes (ppr field_name)] + +checkTypeCtxt ctxt ty + = vcat [ptext SLIT("In the type:") <+> ppr_ty, + ptext SLIT("While checking") <+> pprUserTypeCtxt ctxt ] + where + -- Hack alert. If there are no tyvars, (ppr sigma_ty) will print + -- something strange like {Eq k} -> k -> k, because there is no + -- ForAll at the top of the type. Since this is going to the user + -- we want it to look like a proper Haskell type even then; hence the hack + -- + -- This shows up in the complaint about + -- case C a where + -- op :: Eq a => a -> a + ppr_ty | null forall_tvs = pprThetaArrow theta <+> ppr tau + | otherwise = ppr ty + + (forall_tvs, theta, tau) = tcSplitSigmaTy ty + +dataConCtxt con = sep [ptext SLIT("When checking the data constructor:"), + nest 2 (ex_part <+> pprThetaArrow ex_theta <+> ppr con <+> arg_part)] where - pp_decl decl = hsep [quotes (ppr (tcdName decl)), - ptext SLIT("at"), ppr (tcdLoc decl)] + (_, _, ex_tvs, ex_theta, arg_tys, _) = dataConSig con + ex_part | null ex_tvs = empty + | otherwise = ptext SLIT("forall") <+> hsep (map ppr ex_tvs) <> dot + -- The 'ex_theta' part could be non-empty, if the user (bogusly) wrote + -- data T a = Eq a => T a a + -- So we make sure to print it + + fields = dataConFieldLabels con + arg_part | null fields = sep (map pprParendType arg_tys) + | otherwise = braces (sep (punctuate comma + [ ppr n <+> dcolon <+> ppr ty + | (n,ty) <- fields `zip` arg_tys])) + +classOpCtxt sel_id = sep [ptext SLIT("When checking the class method:"), + nest 2 (ppr sel_id <+> dcolon <+> ppr (idType sel_id))] + +nullaryClassErr cls + = ptext SLIT("No parameters for class") <+> quotes (ppr cls) + +classArityErr cls + = vcat [ptext SLIT("Too many parameters for class") <+> quotes (ppr cls), + parens (ptext SLIT("Use -fglasgow-exts to allow multi-parameter classes"))] + +genericMultiParamErr clas + = ptext SLIT("The multi-parameter class") <+> quotes (ppr clas) <+> + ptext SLIT("cannot have generic methods") + +badGenericMethodType op op_ty + = hang (ptext SLIT("Generic method type is too complex")) + 4 (vcat [ppr op <+> dcolon <+> ppr op_ty, + ptext SLIT("You can only use type variables, arrows, and tuples")]) + +recSynErr tcs + = addSrcLoc (getSrcLoc (head tcs)) $ + addErr (sep [ptext SLIT("Cycle in type synonym declarations:"), + nest 2 (vcat (map ppr_thing tcs))]) + +recClsErr clss + = addSrcLoc (getSrcLoc (head clss)) $ + addErr (sep [ptext SLIT("Cycle in class declarations (via superclasses):"), + nest 2 (vcat (map ppr_thing clss))]) + +ppr_thing :: Name -> SDoc +ppr_thing n = ppr n <+> parens (ppr (getSrcLoc n)) + + +exRecConErr name + = ptext SLIT("Can't combine named fields with locally-quantified type variables") + $$ + (ptext SLIT("In the declaration of data constructor") <+> ppr name) \end{code} diff --git a/ghc/compiler/typecheck/TcTyDecls.lhs b/ghc/compiler/typecheck/TcTyDecls.lhs index bc339cc4bd..e67cabe487 100644 --- a/ghc/compiler/typecheck/TcTyDecls.lhs +++ b/ghc/compiler/typecheck/TcTyDecls.lhs @@ -1,225 +1,483 @@ % -% (c) The AQUA Project, Glasgow University, 1996-1998 +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1999 % -\section[TcTyDecls]{Typecheck type declarations} + +Analysis functions over data types. Specficially + a) detecting recursive types + b) computing argument variances + +This stuff is only used for source-code decls; it's recorded in interface +files for imported data types. + \begin{code} -module TcTyDecls ( tcTyDecl, kcConDetails, tcMkDataCon ) where +module TcTyDecls( + calcTyConArgVrcs, tyVarVrc, + calcRecFlags, calcCycleErrs, + newTyConRhs + ) where #include "HsVersions.h" -import HsSyn ( TyClDecl(..), ConDecl(..), HsConDetails(..), BangType, - getBangType, getBangStrictness, conDetailsTys - ) -import RnHsSyn ( RenamedTyClDecl, RenamedConDecl, RenamedContext ) -import BasicTypes ( NewOrData(..), StrictnessMark(..) ) - -import TcMonoType ( tcHsTyVars, tcHsTheta, tcHsType, - kcHsContext, kcHsSigType, kcHsLiftedSigType - ) -import TcEnv ( tcExtendTyVarEnv, tcLookupTyCon, TyThingDetails(..) ) -import TcType ( Type, tyVarsOfTypes, tyVarsOfPred, ThetaType ) -import RnEnv ( lookupSysName ) -import TcRnMonad - -import DataCon ( DataCon, mkDataCon, dataConFieldLabels ) -import FieldLabel ( FieldLabel, fieldLabelName, fieldLabelType, allFieldLabelTags, mkFieldLabel ) -import MkId ( mkDataConWorkId, mkDataConWrapId, mkRecordSelId ) -import Var ( TyVar ) -import Name ( Name ) -import OccName ( mkDataConWrapperOcc, mkDataConWorkerOcc, mkGenOcc1, mkGenOcc2 ) +import TypeRep ( Type(..), TyNote(..), PredType(..) ) -- friend +import HsSyn ( TyClDecl(..), HsPred(..) ) +import RnHsSyn ( extractHsTyNames ) +import Type ( predTypeRep ) +import BuildTyCl ( newTyConRhs ) +import HscTypes ( TyThing(..) ) +import TyCon ( TyCon, ArgVrcs, tyConArity, tyConDataCons_maybe, tyConDataCons, tyConTyVars, + getSynTyConDefn, isSynTyCon, isAlgTyCon, isHiBootTyCon, + tyConName, isNewTyCon, isProductTyCon, tyConArgVrcs ) +import Class ( classTyCon ) +import DataCon ( dataConRepArgTys, dataConOrigArgTys ) +import Var ( TyVar ) +import VarSet +import Name ( Name, isTyVarName ) +import NameEnv +import NameSet +import Digraph ( SCC(..), stronglyConnComp, stronglyConnCompR ) +import Maybe ( isNothing ) +import BasicTypes ( RecFlag(..) ) import Outputable -import TyCon ( TyCon, DataConDetails(..), visibleDataCons, - tyConTyVars, tyConName ) -import VarSet ( intersectVarSet, isEmptyVarSet ) -import Generics ( mkTyConGenInfo ) -import CmdLineOpts ( DynFlag(..) ) -import List ( nubBy ) \end{code} + %************************************************************************ %* * -\subsection{Type checking} + Cycles in class and type synonym declarations %* * %************************************************************************ -\begin{code} -tcTyDecl :: RenamedTyClDecl -> TcM (Name, TyThingDetails) -tcTyDecl (TySynonym {tcdName = tycon_name, tcdSynRhs = rhs}) - = tcLookupTyCon tycon_name `thenM` \ tycon -> - tcExtendTyVarEnv (tyConTyVars tycon) $ - tcHsType rhs `thenM` \ rhs_ty -> - returnM (tycon_name, SynTyDetails rhs_ty) - -tcTyDecl (TyData {tcdND = new_or_data, tcdCtxt = context, - tcdName = tycon_name, tcdCons = con_decls, - tcdGeneric = generic}) - = tcLookupTyCon tycon_name `thenM` \ tycon -> - let - tyvars = tyConTyVars tycon - in - tcExtendTyVarEnv tyvars $ - tcHsTheta context `thenM` \ ctxt -> - tcConDecls new_or_data tycon tyvars ctxt con_decls `thenM` \ data_cons -> - let - sel_ids = mkRecordSelectors tycon data_cons - in - tcGenericInfo tycon generic `thenM` \ gen_info -> - returnM (tycon_name, DataTyDetails ctxt data_cons sel_ids gen_info) - -tcTyDecl (ForeignType {tcdName = tycon_name}) - = returnM (tycon_name, ForeignTyDetails) - - -tcGenericInfo tycon generics -- Source code decl: consult the flag - = do_we_want generics `thenM` \ want_generics -> - if want_generics then - mapM (lookupSysName (tyConName tycon)) - [mkGenOcc1, mkGenOcc2] `thenM` \ gen_sys_names -> - returnM (mkTyConGenInfo tycon gen_sys_names) - else - returnM Nothing +We check for type synonym and class cycles on the *source* code. +Main reasons: + + a) Otherwise we'd need a special function to extract type-synonym tycons + from a type, whereas we have extractHsTyNames already + + b) If we checked for type synonym loops after building the TyCon, we + can't do a hoistForAllTys on the type synonym rhs, (else we fall into + a black hole) which seems unclean. Apart from anything else, it'd mean + that a type-synonym rhs could have for-alls to the right of an arrow, + which means adding new cases to the validity checker + + Indeed, in general, checking for cycles beforehand means we need to + be less careful about black holes through synonym cycles. + +The main disadvantage is that a cycle that goes via a type synonym in an +.hi-boot file can lead the compiler into a loop, because it assumes that cycles +only occur in source code. But hi-boot files are trusted anyway, so this isn't +much worse than (say) a kind error. + +[ NOTE ---------------------------------------------- +If we reverse this decision, this comment came from tcTyDecl1, and should + go back there + -- dsHsType, not tcHsKindedType, to avoid a loop. tcHsKindedType does hoisting, + -- which requires looking through synonyms... and therefore goes into a loop + -- on (erroneously) recursive synonyms. + -- Solution: do not hoist synonyms, because they'll be hoisted soon enough + -- when they are substituted + +We'd also need to add back in this definition + +synTyConsOfType :: Type -> [TyCon] +-- Does not look through type synonyms at all +-- Return a list of synonym tycons +synTyConsOfType ty + = nameEnvElts (go ty) where - do_we_want (Just g) = returnM g -- Interface file decl - -- so look at decl - do_we_want Nothing = doptM Opt_Generics -- Source code decl - -- so look at flag - -mkRecordSelectors tycon data_cons - = -- We'll check later that fields with the same name - -- from different constructors have the same type. - [ mkRecordSelId tycon field - | field <- nubBy eq_name fields ] + go :: Type -> NameEnv TyCon -- The NameEnv does duplicate elim + go (TyVarTy v) = emptyNameEnv + go (TyConApp tc tys) = go_tc tc tys -- See note (a) + go (NewTcApp tc tys) = go_s tys -- Ignore tycon + go (AppTy a b) = go a `plusNameEnv` go b + go (FunTy a b) = go a `plusNameEnv` go b + go (PredTy (IParam _ ty)) = go ty + go (PredTy (ClassP cls tys)) = go_s tys -- Ignore class + go (NoteTy (SynNote ty) _) = go ty -- Don't look through it! + go (NoteTy other ty) = go ty + go (ForAllTy _ ty) = go ty + + -- Note (a): the unexpanded branch of a SynNote has a + -- TyConApp for the synonym, so the tc of + -- a TyConApp must be tested for possible synonyms + + go_tc tc tys | isSynTyCon tc = extendNameEnv (go_s tys) (tyConName tc) tc + | otherwise = go_s tys + go_s tys = foldr (plusNameEnv . go) emptyNameEnv tys +---------------------------------------- END NOTE ] + +\begin{code} +calcCycleErrs :: [TyClDecl Name] -> ([[Name]], -- Recursive type synonym groups + [[Name]]) -- Ditto classes +calcCycleErrs decls + = (findCyclics syn_edges, findCyclics cls_edges) where - fields = [ field | con <- visibleDataCons data_cons, - field <- dataConFieldLabels con ] - eq_name field1 field2 = fieldLabelName field1 == fieldLabelName field2 + --------------- Type synonyms ---------------------- + syn_edges = [ (name, mk_syn_edges rhs) | TySynonym { tcdName = name, tcdSynRhs = rhs } <- decls ] + mk_syn_edges rhs = [ tc | tc <- nameSetToList (extractHsTyNames rhs), not (isTyVarName tc) ] + + --------------- Classes ---------------------- + cls_edges = [ (name, mk_cls_edges ctxt) | ClassDecl { tcdName = name, tcdCtxt = ctxt } <- decls ] + mk_cls_edges ctxt = [ cls | HsClassP cls _ <- ctxt ] \end{code} %************************************************************************ %* * -\subsection{Kind and type check constructors} + Deciding which type constructors are recursive %* * %************************************************************************ +A newtype M.T is defined to be "recursive" iff + (a) its rhs mentions an abstract (hi-boot) TyCon + or (b) one can get from T's rhs to T via type + synonyms, or non-recursive newtypes *in M* + e.g. newtype T = MkT (T -> Int) + +(a) is conservative; it assumes that the hi-boot type can loop + around to T. That's why in (b) we can restrict attention + to tycons in M, because any loops through newtypes outside M + will be broken by those newtypes + +An algebraic data type M.T is "recursive" iff + it has just one constructor, and + (a) its arg types mention an abstract (hi-boot) TyCon + or (b) one can get from its arg types to T via type synonyms, + or by non-recursive newtypes or non-recursive product types in M + e.g. data T = MkT (T -> Int) Bool + +A type synonym is recursive if one can get from its +right hand side back to it via type synonyms. (This is +reported as an error.) + +A class is recursive if one can get from its superclasses +back to it. (This is an error too.) + +Hi-boot types +~~~~~~~~~~~~~ +A data type read from an hi-boot file will have an Unknown in its data constructors, +and will respond True to isHiBootTyCon. The idea is that we treat these as if one +could get from these types to anywhere. So when we see + + module Baz where + import {-# SOURCE #-} Foo( T ) + newtype S = MkS T + +then we mark S as recursive, just in case. What that means is that if we see + + import Baz( S ) + newtype R = MkR S + +then we don't need to look inside S to compute R's recursiveness. Since S is imported +(not from an hi-boot file), one cannot get from R back to S except via an hi-boot file, +and that means that some data type will be marked recursive along the way. So R is +unconditionly non-recursive (i.e. there'll be a loop breaker elsewhere if necessary) + +This in turn means that we grovel through fewer interface files when computing +recursiveness, because we need only look at the type decls in the module being +compiled, plus the outer structure of directly-mentioned types. + \begin{code} -kcConDetails :: NewOrData -> RenamedContext - -> HsConDetails Name (BangType Name) -> TcM () -kcConDetails new_or_data ex_ctxt details - = kcHsContext ex_ctxt `thenM_` - mappM_ kc_sig_type (conDetailsTys details) - where - kc_sig_type = case new_or_data of - DataType -> kcHsSigType - NewType -> kcHsLiftedSigType - -- Can't allow an unlifted type here, because we're effectively - -- going to remove the constructor while coercing it to a lifted type. - - -tcConDecls :: NewOrData -> TyCon -> [TyVar] -> ThetaType - -> DataConDetails RenamedConDecl -> TcM (DataConDetails DataCon) - -tcConDecls new_or_data tycon tyvars ctxt con_decls - = case con_decls of - Unknown -> returnM Unknown - HasCons n -> returnM (HasCons n) - DataCons cs -> mappM tc_con_decl cs `thenM` \ data_cons -> - returnM (DataCons data_cons) +calcRecFlags :: [TyThing] -> (Name -> RecFlag) +calcRecFlags tyclss + = is_rec where - tc_con_decl (ConDecl name ex_tvs ex_ctxt details src_loc) - = addSrcLoc src_loc $ - tcHsTyVars ex_tvs (kcConDetails new_or_data ex_ctxt details) $ \ ex_tyvars -> - tcHsTheta ex_ctxt `thenM` \ ex_theta -> - case details of - PrefixCon btys -> tc_datacon ex_tyvars ex_theta btys - InfixCon bty1 bty2 -> tc_datacon ex_tyvars ex_theta [bty1,bty2] - RecCon fields -> tc_rec_con ex_tyvars ex_theta fields - where + is_rec n | n `elemNameSet` rec_names = Recursive + | otherwise = NonRecursive + + rec_names = nt_loop_breakers `unionNameSets` prod_loop_breakers + + all_tycons = map getTyCon tyclss -- Recursion of newtypes/data types + -- can happen via the class TyCon + + ------------------------------------------------- + -- NOTE + -- These edge-construction loops rely on + -- every loop going via tyclss, the types and classes + -- in the module being compiled. Stuff in interface + -- files should be correctly marked. If not (e.g. a + -- type synonym in a hi-boot file) we can get an infinite + -- loop. We could program round this, but it'd make the code + -- rather less nice, so I'm not going to do that yet. + + --------------- Newtypes ---------------------- + new_tycons = filter isNewTyCon all_tycons + nt_loop_breakers = mkNameSet (findLoopBreakers nt_edges) + is_rec_nt tc = tyConName tc `elemNameSet` nt_loop_breakers + -- is_rec_nt is a locally-used helper function + + nt_edges = [(t, mk_nt_edges t) | t <- new_tycons] + + mk_nt_edges nt -- Invariant: nt is a newtype + = concatMap (mk_nt_edges1 nt) (tcTyConsOfType (newTyConRhs nt)) + -- tyConsOfType looks through synonyms + + mk_nt_edges1 nt tc + | tc `elem` new_tycons = [tc] -- Loop + | isHiBootTyCon tc = [nt] -- Make it self-recursive if + -- it mentions an hi-boot TyCon + -- At this point we know that either it's a local data type, + -- or it's imported. Either way, it can't form part of a cycle + | otherwise = [] + + --------------- Product types ---------------------- + -- The "prod_tycons" are the non-newtype products + prod_tycons = [tc | tc <- all_tycons, + not (isNewTyCon tc), isProductTyCon tc] + prod_loop_breakers = mkNameSet (findLoopBreakers prod_edges) + + prod_edges = [(tc, mk_prod_edges tc) | tc <- prod_tycons] - tc_datacon ex_tyvars ex_theta btys - = mappM tcHsType (map getBangType btys) `thenM` \ 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_` - mappM tc_field (fields `zip` allFieldLabelTags) `thenM` \ field_labels -> - let - arg_stricts = [getBangStrictness bty | (n, bty) <- fields] - arg_tys = map fieldLabelType field_labels - in - 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) - -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" - - doptM Opt_UnboxStrictFields `thenM` \ unbox_strict_fields -> - - let - real_stricts - | unbox_strict_fields = map unboxUserStrict arg_stricts - | otherwise = arg_stricts - - unboxUserStrict MarkedUserStrict = MarkedUserUnboxed - unboxUserStrict other = other - - data_con = mkDataCon src_name real_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 -thinContext arg_tys ctxt - = filter in_arg_tys ctxt + mk_prod_edges tc -- Invariant: tc is a product tycon + = concatMap (mk_prod_edges1 tc) (dataConOrigArgTys (head (tyConDataCons tc))) + + mk_prod_edges1 ptc ty = concatMap (mk_prod_edges2 ptc) (tcTyConsOfType ty) + + mk_prod_edges2 ptc tc + | tc `elem` prod_tycons = [tc] -- Local product + | tc `elem` new_tycons = if is_rec_nt tc -- Local newtype + then [] + else mk_prod_edges1 ptc (newTyConRhs tc) + | isHiBootTyCon tc = [ptc] -- Make it self-recursive if + -- it mentions an hi-boot TyCon + -- At this point we know that either it's a local non-product data type, + -- or it's imported. Either way, it can't form part of a cycle + | otherwise = [] + +getTyCon (ATyCon tc) = tc +getTyCon (AClass cl) = classTyCon cl + +findLoopBreakers :: [(TyCon, [TyCon])] -> [Name] +-- Finds a set of tycons that cut all loops +findLoopBreakers deps + = go [(tc,tc,ds) | (tc,ds) <- deps] + where + go edges = [ name + | CyclicSCC ((tc,_,_) : edges') <- stronglyConnCompR edges, + name <- tyConName tc : go edges'] + +findCyclics :: [(Name,[Name])] -> [[Name]] +findCyclics deps + = [names | CyclicSCC names <- stronglyConnComp edges] + where + edges = [(name,name,ds) | (name,ds) <- deps] +\end{code} + +These two functions know about type representations, so they could be +in Type or TcType -- but they are very specialised to this module, so +I've chosen to put them here. + +\begin{code} +tcTyConsOfType :: Type -> [TyCon] +-- tcTyConsOfType looks through all synonyms, but not through any newtypes. +-- When it finds a Class, it returns the class TyCon. The reaons it's here +-- (not in Type.lhs) is because it is newtype-aware. +tcTyConsOfType ty + = nameEnvElts (go ty) where - arg_tyvars = tyVarsOfTypes arg_tys - in_arg_tys pred = not $ isEmptyVarSet $ - tyVarsOfPred pred `intersectVarSet` arg_tyvars + go :: Type -> NameEnv TyCon -- The NameEnv does duplicate elim + go (TyVarTy v) = emptyNameEnv + go (TyConApp tc tys) = go_tc tc tys + go (NewTcApp tc tys) = go_tc tc tys + go (AppTy a b) = go a `plusNameEnv` go b + go (FunTy a b) = go a `plusNameEnv` go b + go (PredTy (IParam _ ty)) = go ty + go (PredTy (ClassP cls tys)) = go_tc (classTyCon cls) tys + go (NoteTy _ ty) = go ty + go (ForAllTy _ ty) = go ty + + go_tc tc tys = extendNameEnv (go_s tys) (tyConName tc) tc + go_s tys = foldr (plusNameEnv . go) emptyNameEnv tys \end{code} %************************************************************************ %* * -\subsection{Errors and contexts} + Compuing TyCon argument variances %* * %************************************************************************ +Computing the tyConArgVrcs info +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +@tyConArgVrcs@ gives a list of (occPos,occNeg) flags, one for each +tyvar. For @AlgTyCon@s and @SynTyCon@s, this info must be precomputed +separately. Note that this is information about occurrences of type +variables, not usages of term variables. + +The function @calcTyConArgVrcs@ must be passed a list of *algebraic or +syntycons only* such that all tycons referred to (by mutual recursion) +appear in the list. The fixpointing will be done on this set of +tycons as a whole. It returns a list of @tyconVrcInfo@ data, ready to +be (knot-tyingly?) stuck back into the appropriate fields. + +\begin{code} +calcTyConArgVrcs :: [TyThing] -> Name -> ArgVrcs +-- Gives arg variances for TyCons, +-- including the class TyCon of a class +calcTyConArgVrcs tyclss + = get_vrc + where + tycons = map getTyCon tyclss + + -- We should only look up things that are in the map + get_vrc n = case lookupNameEnv final_oi n of + Just (_, pms) -> pms + Nothing -> pprPanic "calcVrcs" (ppr n) + + -- We are going to fold over this map, + -- so we need the TyCon in the range + final_oi :: NameEnv (TyCon, ArgVrcs) + final_oi = tcaoFix initial_oi + + initial_oi :: NameEnv (TyCon, ArgVrcs) + initial_oi = mkNameEnv [(tyConName tc, (tc, initial tc)) + | tc <- tycons] + initial tc = if isAlgTyCon tc && isNothing (tyConDataCons_maybe tc) then + -- make pessimistic assumption (and warn) + abstractVrcs tc + else + replicate (tyConArity tc) (False,False) + + tcaoFix :: NameEnv (TyCon, ArgVrcs) -- initial ArgVrcs per tycon + -> NameEnv (TyCon, ArgVrcs) -- fixpointed ArgVrcs per tycon + tcaoFix oi + | changed = tcaoFix oi' + | otherwise = oi' + where + (changed,oi') = foldNameEnv iterate (False,oi) oi + + iterate (tc, pms) (changed,oi') + = (changed || (pms /= pms'), + extendNameEnv oi' (tyConName tc) (tc, pms')) + where + pms' = tcaoIter oi' tc -- seq not simult + + tcaoIter :: NameEnv (TyCon, ArgVrcs) -- reference ArgVrcs (initial) + -> TyCon -- tycon to update + -> ArgVrcs -- new ArgVrcs for tycon + + tcaoIter oi tc | isAlgTyCon tc + = if null data_cons then + abstractVrcs tc -- Data types with no constructors + else + map (\v -> anyVrc (vrcInTy (lookup oi) v) argtys) vs + where + data_cons = tyConDataCons tc + vs = tyConTyVars tc + argtys = concatMap dataConRepArgTys data_cons -- Rep? or Orig? + + tcaoIter oi tc | isSynTyCon tc + = let (tyvs,ty) = getSynTyConDefn tc + -- we use the already-computed result for tycons not in this SCC + in map (\v -> vrcInTy (lookup oi) v ty) tyvs + + lookup oi tc = case lookupNameEnv oi (tyConName tc) of + Just (_, pms) -> pms + Nothing -> tyConArgVrcs tc + -- We use the already-computed result for tycons not in this SCC + + +abstractVrcs :: TyCon -> ArgVrcs +abstractVrcs tc = +#ifdef DEBUG + pprTrace "Vrc: abstract tycon:" (ppr tc) $ +#endif + warn_abstract_vrcs `seq` replicate (tyConArity tc) (True,True) + +warn_abstract_vrcs +-- we pull the message out as a CAF so the warning only appears *once* + = trace ("WARNING: tyConArgVrc info inaccurate due to unavailable constructors.\n" + ++ " Use -fno-prune-tydecls to fix.") $ + () +\end{code} + + +Variance of tyvars in a type +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +A general variance-check function. We pass a function for determining +the @ArgVrc@s of a tycon; when fixpointing this refers to the current +value; otherwise this should be looked up from the tycon's own +tyConArgVrcs. Again, it knows the representation of Types. + +\begin{code} +vrcInTy :: (TyCon -> ArgVrcs) -- function to get argVrcs of a tycon (break out of recursion) + -> TyVar -- tyvar to check Vrcs of + -> Type -- type to check for occ in + -> (Bool,Bool) -- (occurs positively, occurs negatively) + +vrcInTy fao v (NoteTy (SynNote _) ty) = vrcInTy fao v ty + -- SynTyCon doesn't neccessarily have vrcInfo at this point, + -- so don't try and use it + +vrcInTy fao v (NoteTy (FTVNote ftv) ty) = if elemVarSet v ftv + then vrcInTy fao v ty + else (False,False) + -- note that ftv cannot be calculated as occPos||occNeg, + -- since if a tyvar occurs only as unused tyconarg, + -- occPos==occNeg==False, but ftv=True + +vrcInTy fao v (TyVarTy v') = if v==v' + then (True,False) + else (False,False) + +vrcInTy fao v (AppTy ty1 ty2) = if vrcInTy fao v ty2 /= (False,False) + then (True,True) + else vrcInTy fao v ty1 + -- ty1 is probably unknown (or it would have been beta-reduced); + -- hence if v occurs in ty2 at all then it could occur with + -- either variance. Otherwise it occurs as it does in ty1. + +vrcInTy fao v (FunTy ty1 ty2) = negVrc (vrcInTy fao v ty1) + `orVrc` + vrcInTy fao v ty2 + +vrcInTy fao v (ForAllTy v' ty) = if v==v' + then (False,False) + else vrcInTy fao v ty + +vrcInTy fao v (TyConApp tc tys) = let pms1 = map (vrcInTy fao v) tys + pms2 = fao tc + in orVrcs (zipWith timesVrc pms1 pms2) + +vrcInTy fao v (NewTcApp tc tys) = let pms1 = map (vrcInTy fao v) tys + pms2 = fao tc + in orVrcs (zipWith timesVrc pms1 pms2) + +vrcInTy fao v (PredTy st) = vrcInTy fao v (predTypeRep st) +\end{code} + + +External entry point: assumes tyconargvrcs already computed. + +\begin{code} +tyVarVrc :: TyVar -- tyvar to check Vrc of + -> Type -- type to check for occ in + -> (Bool,Bool) -- (occurs positively, occurs negatively) + +tyVarVrc = vrcInTy tyConArgVrcs +\end{code} + + +Variance algebra +~~~~~~~~~~~~~~~~ \begin{code} -exRecConErr name - = ptext SLIT("Can't combine named fields with locally-quantified type variables") - $$ - (ptext SLIT("In the declaration of data constructor") <+> ppr name) +orVrc :: (Bool,Bool) -> (Bool,Bool) -> (Bool,Bool) +orVrc (p1,m1) (p2,m2) = (p1||p2,m1||m2) + +orVrcs :: [(Bool,Bool)] -> (Bool,Bool) +orVrcs = foldl orVrc (False,False) + +negVrc :: (Bool,Bool) -> (Bool,Bool) +negVrc (p1,m1) = (m1,p1) + +anyVrc :: (a -> (Bool,Bool)) -> [a] -> (Bool,Bool) +anyVrc p as = foldl (\ pm a -> pm `orVrc` p a) + (False,False) as + +timesVrc :: (Bool,Bool) -> (Bool,Bool) -> (Bool,Bool) +timesVrc (p1,m1) (p2,m2) = (p1 && p2 || m1 && m2, + p1 && m2 || m1 && p2) \end{code} diff --git a/ghc/compiler/typecheck/TcType.lhs b/ghc/compiler/typecheck/TcType.lhs index 079f225dfe..6f7fdde7a3 100644 --- a/ghc/compiler/typecheck/TcType.lhs +++ b/ghc/compiler/typecheck/TcType.lhs @@ -16,10 +16,6 @@ is the principal client. \begin{code} module TcType ( -------------------------------- - -- TyThing - TyThing(..), -- instance NamedThing - - -------------------------------- -- Types TcType, TcSigmaType, TcRhoType, TcTauType, TcPredType, TcThetaType, TcTyVar, TcTyVarSet, TcKind, @@ -54,14 +50,14 @@ module TcType ( --------------------------------- -- Misc type manipulators - deNoteType, classNamesOfTheta, + deNoteType, classesOfTheta, tyClsNamesOfType, tyClsNamesOfDFunHead, getDFunTyKey, --------------------------------- -- Predicate types getClassPredTys_maybe, getClassPredTys, - isPredTy, isClassPred, isTyVarClassPred, + isClassPred, isTyVarClassPred, mkDictTy, tcSplitPredTy_maybe, isDictTy, tcSplitDFunTy, predTyUnique, mkClassPred, isInheritablePred, isLinearPred, isIPPred, mkPredName, @@ -92,7 +88,7 @@ module TcType ( superBoxity, liftedBoxity, hasMoreBoxityInfo, defaultKind, superKind, isTypeKind, isAnyTypeKind, - Type, SourceType(..), PredType, ThetaType, + Type, PredType(..), ThetaType, mkForAllTy, mkForAllTys, mkFunTy, mkFunTys, zipFunTys, mkTyConApp, mkGenTyConApp, mkAppTy, mkAppTys, mkSynTy, applyTy, applyTys, @@ -100,7 +96,7 @@ module TcType ( isUnLiftedType, -- Source types are always lifted isUnboxedTupleType, -- Ditto - isPrimitiveType, isTyVarTy, + isPrimitiveType, isTyVarTy, isPredTy, tidyTopType, tidyType, tidyPred, tidyTypes, tidyFreeTyVars, tidyOpenType, tidyOpenTypes, tidyTyVarBndr, tidyOpenTyVar, tidyOpenTyVars, @@ -120,8 +116,8 @@ import TypeRep ( Type(..), TyNote(..), funTyCon ) -- friend import Type ( -- Re-exports tyVarsOfType, tyVarsOfTypes, tyVarsOfPred, - tyVarsOfTheta, Kind, Type, SourceType(..), - PredType, ThetaType, unliftedTypeKind, + tyVarsOfTheta, Kind, Type, PredType(..), + ThetaType, unliftedTypeKind, liftedTypeKind, openTypeKind, mkArrowKind, mkArrowKinds, mkForAllTy, mkForAllTys, defaultKind, isTypeKind, isAnyTypeKind, @@ -129,7 +125,7 @@ import Type ( -- Re-exports mkTyConApp, mkGenTyConApp, mkAppTy, mkAppTys, mkSynTy, applyTy, applyTys, mkTyVarTy, mkTyVarTys, mkTyConTy, mkPredTy, - mkPredTys, isUnLiftedType, + mkPredTys, isUnLiftedType, isPredTy, isUnboxedTupleType, isPrimitiveType, splitTyConApp_maybe, tidyTopType, tidyType, tidyPred, tidyTypes, @@ -139,10 +135,9 @@ import Type ( -- Re-exports hasMoreBoxityInfo, liftedBoxity, superBoxity, typeKind, superKind, repType ) -import DataCon ( DataCon ) import TyCon ( TyCon, isUnLiftedTyCon, tyConUnique ) -import Class ( classHasFDs, Class ) -import Var ( TyVar, Id, tyVarKind, isMutTyVar, mutTyVarDetails ) +import Class ( Class ) +import Var ( TyVar, tyVarKind, isMutTyVar, mutTyVarDetails ) import ForeignCall ( Safety, playSafe , DNType(..) ) @@ -152,8 +147,8 @@ import VarSet -- others: import CmdLineOpts ( DynFlags, DynFlag( Opt_GlasgowExts ), dopt ) import Name ( Name, NamedThing(..), mkInternalName, getSrcLoc ) -import OccName ( OccName, mkDictOcc ) import NameSet +import OccName ( OccName, mkDictOcc ) import PrelNames -- Lots (e.g. in isFFIArgumentTy) import TysWiredIn ( unitTyCon, charTyCon, listTyCon ) import BasicTypes ( IPName(..), ipNameName ) @@ -167,26 +162,6 @@ 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} %* * %************************************************************************ @@ -220,13 +195,6 @@ tau ::= tyvar -- In all cases, a (saturated) type synonym application is legal, -- provided it expands to the required form. - -\begin{code} -type SigmaType = Type -type RhoType = Type -type TauType = Type -\end{code} - \begin{code} type TcTyVar = TyVar -- Might be a mutable tyvar type TcTyVarSet = TyVarSet @@ -273,10 +241,6 @@ data TyVarDetails | InstTv -- Ditto, but instance decl - | PatSigTv -- Scoped type variable, introduced by a pattern - -- type signature - -- \ x::a -> e - | VanillaTv -- Everything else isUserTyVar :: TcTyVar -> Bool -- Avoid unifying these if possible @@ -302,7 +266,6 @@ tyVarBindingInfo tv details SigTv = ptext SLIT("type signature") details ClsTv = ptext SLIT("class declaration") details InstTv = ptext SLIT("instance declaration") - details PatSigTv = ptext SLIT("pattern type signature") details VanillaTv = ptext SLIT("//vanilla//") -- Ditto \end{code} @@ -316,20 +279,20 @@ tyVarBindingInfo tv \begin{code} mkSigmaTy tyvars theta tau = mkForAllTys tyvars (mkPhiTy theta tau) -mkPhiTy :: [SourceType] -> Type -> Type +mkPhiTy :: [PredType] -> Type -> Type mkPhiTy theta ty = foldr (\p r -> FunTy (mkPredTy p) r) ty theta \end{code} - @isTauTy@ tests for nested for-alls. \begin{code} isTauTy :: Type -> Bool isTauTy (TyVarTy v) = True isTauTy (TyConApp _ tys) = all isTauTy tys +isTauTy (NewTcApp _ tys) = all isTauTy tys isTauTy (AppTy a b) = isTauTy a && isTauTy b isTauTy (FunTy a b) = isTauTy a && isTauTy b -isTauTy (SourceTy p) = True -- Don't look through source types +isTauTy (PredTy p) = True -- Don't look through source types isTauTy (NoteTy _ ty) = isTauTy ty isTauTy other = False \end{code} @@ -337,15 +300,15 @@ isTauTy other = False \begin{code} getDFunTyKey :: Type -> OccName -- Get some string from a type, to be used to -- construct a dictionary function name -getDFunTyKey (TyVarTy tv) = getOccName tv -getDFunTyKey (TyConApp tc _) = getOccName tc -getDFunTyKey (AppTy fun _) = getDFunTyKey fun -getDFunTyKey (NoteTy _ t) = getDFunTyKey t -getDFunTyKey (FunTy arg _) = getOccName funTyCon -getDFunTyKey (ForAllTy _ t) = getDFunTyKey t -getDFunTyKey (SourceTy (NType tc _)) = getOccName tc -- Newtypes are quite reasonable -getDFunTyKey ty = pprPanic "getDFunTyKey" (pprType ty) --- SourceTy shouldn't happen +getDFunTyKey (TyVarTy tv) = getOccName tv +getDFunTyKey (TyConApp tc _) = getOccName tc +getDFunTyKey (NewTcApp tc _) = getOccName tc +getDFunTyKey (AppTy fun _) = getDFunTyKey fun +getDFunTyKey (NoteTy _ t) = getDFunTyKey t +getDFunTyKey (FunTy arg _) = getOccName funTyCon +getDFunTyKey (ForAllTy _ t) = getDFunTyKey t +getDFunTyKey ty = pprPanic "getDFunTyKey" (pprType ty) +-- PredTy shouldn't happen \end{code} @@ -400,10 +363,10 @@ tcSplitTyConApp ty = case tcSplitTyConApp_maybe ty of Nothing -> pprPanic "tcSplitTyConApp" (pprType ty) tcSplitTyConApp_maybe :: Type -> Maybe (TyCon, [Type]) -tcSplitTyConApp_maybe (TyConApp tc tys) = Just (tc, tys) -tcSplitTyConApp_maybe (FunTy arg res) = Just (funTyCon, [arg,res]) -tcSplitTyConApp_maybe (NoteTy n ty) = tcSplitTyConApp_maybe ty -tcSplitTyConApp_maybe (SourceTy (NType tc tys)) = Just (tc,tys) +tcSplitTyConApp_maybe (TyConApp tc tys) = Just (tc, tys) +tcSplitTyConApp_maybe (NewTcApp tc tys) = Just (tc, tys) +tcSplitTyConApp_maybe (FunTy arg res) = Just (funTyCon, [arg,res]) +tcSplitTyConApp_maybe (NoteTy n ty) = tcSplitTyConApp_maybe ty -- Newtypes are opaque, so they may be split -- However, predicates are not treated -- as tycon applications by the type checker @@ -426,16 +389,16 @@ tcFunResultTy ty = case tcSplitFunTy_maybe ty of { Just (arg,res) -> res } tcSplitAppTy_maybe :: Type -> Maybe (Type, Type) -tcSplitAppTy_maybe (FunTy ty1 ty2) = Just (TyConApp funTyCon [ty1], ty2) -tcSplitAppTy_maybe (AppTy ty1 ty2) = Just (ty1, ty2) -tcSplitAppTy_maybe (NoteTy n ty) = tcSplitAppTy_maybe ty -tcSplitAppTy_maybe (SourceTy (NType tc tys)) = tc_split_app tc tys --- Don't forget that newtype! -tcSplitAppTy_maybe (TyConApp tc tys) = tc_split_app tc tys -tcSplitAppTy_maybe other = Nothing - -tc_split_app tc tys = case snocView tys of - Just (tys',ty') -> Just (TyConApp tc tys', ty') - Nothing -> Nothing +tcSplitAppTy_maybe (FunTy ty1 ty2) = Just (TyConApp funTyCon [ty1], ty2) +tcSplitAppTy_maybe (AppTy ty1 ty2) = Just (ty1, ty2) +tcSplitAppTy_maybe (NoteTy n ty) = tcSplitAppTy_maybe ty +tcSplitAppTy_maybe (TyConApp tc tys) = case snocView tys of + Just (tys', ty') -> Just (TyConApp tc tys', ty') + Nothing -> Nothing +tcSplitAppTy_maybe (NewTcApp tc tys) = case snocView tys of + Just (tys', ty') -> Just (NewTcApp tc tys', ty') + Nothing -> Nothing +tcSplitAppTy_maybe other = Nothing tcSplitAppTy ty = case tcSplitAppTy_maybe ty of Just stuff -> stuff @@ -478,7 +441,7 @@ tcSplitMethodTy ty = split ty split (NoteTy n ty) = split ty split _ = panic "splitMethodTy" -tcSplitDFunTy :: Type -> ([TyVar], [SourceType], Class, [Type]) +tcSplitDFunTy :: Type -> ([TyVar], [PredType], Class, [Type]) -- Split the type of a dictionary function tcSplitDFunTy ty = case tcSplitSigmaTy ty of { (tvs, theta, tau) -> @@ -518,30 +481,18 @@ allDistinctTyVars (ty:tys) acc %* * %************************************************************************ -"Predicates" are particular source types, namelyClassP or IParams - \begin{code} -isPred :: SourceType -> Bool -isPred (ClassP _ _) = True -isPred (IParam _ _) = True -isPred (NType _ _) = False - -isPredTy :: Type -> Bool -isPredTy (NoteTy _ ty) = isPredTy ty -isPredTy (SourceTy sty) = isPred sty -isPredTy _ = False - tcSplitPredTy_maybe :: Type -> Maybe PredType -- Returns Just for predicates only -tcSplitPredTy_maybe (NoteTy _ ty) = tcSplitPredTy_maybe ty -tcSplitPredTy_maybe (SourceTy p) | isPred p = Just p -tcSplitPredTy_maybe other = Nothing +tcSplitPredTy_maybe (NoteTy _ ty) = tcSplitPredTy_maybe ty +tcSplitPredTy_maybe (PredTy p) = Just p +tcSplitPredTy_maybe other = Nothing predTyUnique :: PredType -> Unique predTyUnique (IParam n _) = getUnique (ipNameName n) predTyUnique (ClassP clas tys) = getUnique clas -mkPredName :: Unique -> SrcLoc -> SourceType -> Name +mkPredName :: Unique -> SrcLoc -> PredType -> Name mkPredName uniq loc (ClassP cls tys) = mkInternalName uniq (mkDictOcc (getOccName cls)) loc mkPredName uniq loc (IParam ip ty) = mkInternalName uniq (getOccName (ipNameName ip)) loc \end{code} @@ -552,14 +503,14 @@ mkPredName uniq loc (IParam ip ty) = mkInternalName uniq (getOccName (ipNameNa \begin{code} mkClassPred clas tys = ClassP clas tys -isClassPred :: SourceType -> Bool +isClassPred :: PredType -> Bool isClassPred (ClassP clas tys) = True isClassPred other = False isTyVarClassPred (ClassP clas tys) = all tcIsTyVarTy tys isTyVarClassPred other = False -getClassPredTys_maybe :: SourceType -> Maybe (Class, [Type]) +getClassPredTys_maybe :: PredType -> Maybe (Class, [Type]) getClassPredTys_maybe (ClassP clas tys) = Just (clas, tys) getClassPredTys_maybe _ = Nothing @@ -570,7 +521,7 @@ mkDictTy :: Class -> [Type] -> Type mkDictTy clas tys = mkPredTy (ClassP clas tys) isDictTy :: Type -> Bool -isDictTy (SourceTy p) = isClassPred p +isDictTy (PredTy p) = isClassPred p isDictTy (NoteTy _ ty) = isDictTy ty isDictTy other = False \end{code} @@ -578,7 +529,7 @@ isDictTy other = False --------------------- Implicit parameters --------------------------------- \begin{code} -isIPPred :: SourceType -> Bool +isIPPred :: PredType -> Bool isIPPred (IParam _ _) = True isIPPred other = False @@ -607,7 +558,6 @@ isLinearPred other = False %************************************************************************ Comparison, taking note of newtypes, predicates, etc, -But ignoring usage types \begin{code} tcEqType :: Type -> Type -> Bool @@ -625,7 +575,7 @@ tcCmpType ty1 ty2 = cmpTy emptyVarEnv ty1 ty2 tcCmpTypes tys1 tys2 = cmpTys emptyVarEnv tys1 tys2 -tcCmpPred p1 p2 = cmpSourceTy emptyVarEnv p1 p2 +tcCmpPred p1 p2 = cmpPredTy emptyVarEnv p1 p2 ------------- cmpTys env tys1 tys2 = cmpList (cmpTy env) tys1 tys2 @@ -644,13 +594,14 @@ cmpTy env (TyVarTy tv1) (TyVarTy tv2) = case lookupVarEnv env tv1 of Just tv1a -> tv1a `compare` tv2 Nothing -> tv1 `compare` tv2 -cmpTy env (SourceTy p1) (SourceTy p2) = cmpSourceTy env p1 p2 +cmpTy env (PredTy p1) (PredTy p2) = cmpPredTy env p1 p2 cmpTy env (AppTy f1 a1) (AppTy f2 a2) = cmpTy env f1 f2 `thenCmp` cmpTy env a1 a2 cmpTy env (FunTy f1 a1) (FunTy f2 a2) = cmpTy env f1 f2 `thenCmp` cmpTy env a1 a2 cmpTy env (TyConApp tc1 tys1) (TyConApp tc2 tys2) = (tc1 `compare` tc2) `thenCmp` (cmpTys env tys1 tys2) +cmpTy env (NewTcApp tc1 tys1) (NewTcApp tc2 tys2) = (tc1 `compare` tc2) `thenCmp` (cmpTys env tys1 tys2) cmpTy env (ForAllTy tv1 t1) (ForAllTy tv2 t2) = cmpTy (extendVarEnv env tv1 tv2) t1 t2 - -- Deal with the rest: TyVarTy < AppTy < FunTy < TyConApp < ForAllTy < SourceTy + -- Deal with the rest: TyVarTy < AppTy < FunTy < TyConApp < NewTcApp < ForAllTy < PredTy cmpTy env (AppTy _ _) (TyVarTy _) = GT cmpTy env (FunTy _ _) (TyVarTy _) = GT @@ -660,38 +611,39 @@ cmpTy env (TyConApp _ _) (TyVarTy _) = GT cmpTy env (TyConApp _ _) (AppTy _ _) = GT cmpTy env (TyConApp _ _) (FunTy _ _) = GT +cmpTy env (NewTcApp _ _) (TyVarTy _) = GT +cmpTy env (NewTcApp _ _) (AppTy _ _) = GT +cmpTy env (NewTcApp _ _) (FunTy _ _) = GT +cmpTy env (NewTcApp _ _) (TyConApp _ _) = GT + cmpTy env (ForAllTy _ _) (TyVarTy _) = GT cmpTy env (ForAllTy _ _) (AppTy _ _) = GT cmpTy env (ForAllTy _ _) (FunTy _ _) = GT cmpTy env (ForAllTy _ _) (TyConApp _ _) = GT +cmpTy env (ForAllTy _ _) (NewTcApp _ _) = GT -cmpTy env (SourceTy _) t2 = GT +cmpTy env (PredTy _) t2 = GT cmpTy env _ _ = LT \end{code} \begin{code} -cmpSourceTy :: TyVarEnv TyVar -> SourceType -> SourceType -> Ordering -cmpSourceTy env (IParam n1 ty1) (IParam n2 ty2) = (n1 `compare` n2) `thenCmp` (cmpTy env ty1 ty2) +cmpPredTy :: TyVarEnv TyVar -> PredType -> PredType -> Ordering +cmpPredTy env (IParam n1 ty1) (IParam n2 ty2) = (n1 `compare` n2) `thenCmp` (cmpTy env ty1 ty2) -- Compare types as well as names for implicit parameters -- This comparison is used exclusively (I think) for the -- finite map built in TcSimplify -cmpSourceTy env (IParam _ _) sty = LT - -cmpSourceTy env (ClassP _ _) (IParam _ _) = GT -cmpSourceTy env (ClassP c1 tys1) (ClassP c2 tys2) = (c1 `compare` c2) `thenCmp` (cmpTys env tys1 tys2) -cmpSourceTy env (ClassP _ _) (NType _ _) = LT - -cmpSourceTy env (NType tc1 tys1) (NType tc2 tys2) = (tc1 `compare` tc2) `thenCmp` (cmpTys env tys1 tys2) -cmpSourceTy env (NType _ _) sty = GT +cmpPredTy env (IParam _ _) (ClassP _ _) = LT +cmpPredTy env (ClassP _ _) (IParam _ _) = GT +cmpPredTy env (ClassP c1 tys1) (ClassP c2 tys2) = (c1 `compare` c2) `thenCmp` (cmpTys env tys1 tys2) \end{code} PredTypes are used as a FM key in TcSimplify, so we take the easy path and make them an instance of Ord \begin{code} -instance Eq SourceType where { (==) = tcEqPred } -instance Ord SourceType where { compare = tcCmpPred } +instance Eq PredType where { (==) = tcEqPred } +instance Ord PredType where { compare = tcCmpPred } \end{code} @@ -744,19 +696,19 @@ is_tc uniq ty = case tcSplitTyConApp_maybe ty of \begin{code} deNoteType :: Type -> Type - -- Remove synonyms, but not source types + -- Remove synonyms, but not predicate types deNoteType ty@(TyVarTy tyvar) = ty deNoteType (TyConApp tycon tys) = TyConApp tycon (map deNoteType tys) -deNoteType (SourceTy p) = SourceTy (deNoteSourceType p) +deNoteType (NewTcApp tycon tys) = NewTcApp tycon (map deNoteType tys) +deNoteType (PredTy p) = PredTy (deNotePredType p) deNoteType (NoteTy _ ty) = deNoteType ty deNoteType (AppTy fun arg) = AppTy (deNoteType fun) (deNoteType arg) deNoteType (FunTy fun arg) = FunTy (deNoteType fun) (deNoteType arg) deNoteType (ForAllTy tv ty) = ForAllTy tv (deNoteType ty) -deNoteSourceType :: SourceType -> SourceType -deNoteSourceType (ClassP c tys) = ClassP c (map deNoteType tys) -deNoteSourceType (IParam n ty) = IParam n (deNoteType ty) -deNoteSourceType (NType tc tys) = NType tc (map deNoteType tys) +deNotePredType :: PredType -> PredType +deNotePredType (ClassP c tys) = ClassP c (map deNoteType tys) +deNotePredType (IParam n ty) = IParam n (deNoteType ty) \end{code} Find the free tycons and classes of a type. This is used in the front @@ -766,11 +718,11 @@ end of the compiler. tyClsNamesOfType :: Type -> NameSet tyClsNamesOfType (TyVarTy tv) = emptyNameSet tyClsNamesOfType (TyConApp tycon tys) = unitNameSet (getName tycon) `unionNameSets` tyClsNamesOfTypes tys +tyClsNamesOfType (NewTcApp tycon tys) = unitNameSet (getName tycon) `unionNameSets` tyClsNamesOfTypes tys tyClsNamesOfType (NoteTy (SynNote ty1) ty2) = tyClsNamesOfType ty1 tyClsNamesOfType (NoteTy other_note ty2) = tyClsNamesOfType ty2 -tyClsNamesOfType (SourceTy (IParam n ty)) = tyClsNamesOfType ty -tyClsNamesOfType (SourceTy (ClassP cl tys)) = unitNameSet (getName cl) `unionNameSets` tyClsNamesOfTypes tys -tyClsNamesOfType (SourceTy (NType tc tys)) = unitNameSet (getName tc) `unionNameSets` tyClsNamesOfTypes tys +tyClsNamesOfType (PredTy (IParam n ty)) = tyClsNamesOfType ty +tyClsNamesOfType (PredTy (ClassP cl tys)) = unitNameSet (getName cl) `unionNameSets` tyClsNamesOfTypes tys tyClsNamesOfType (FunTy arg res) = tyClsNamesOfType arg `unionNameSets` tyClsNamesOfType res tyClsNamesOfType (AppTy fun arg) = tyClsNamesOfType fun `unionNameSets` tyClsNamesOfType arg tyClsNamesOfType (ForAllTy tyvar ty) = tyClsNamesOfType ty @@ -788,9 +740,9 @@ tyClsNamesOfDFunHead dfun_ty = case tcSplitSigmaTy dfun_ty of (tvs,_,head_ty) -> tyClsNamesOfType head_ty -classNamesOfTheta :: ThetaType -> [Name] +classesOfTheta :: ThetaType -> [Class] -- Looks just for ClassP things; maybe it should check -classNamesOfTheta preds = [ getName c | ClassP c _ <- preds ] +classesOfTheta preds = [ c | ClassP c _ <- preds ] \end{code} @@ -1023,18 +975,18 @@ uTysX ty1 (TyVarTy tyvar2) k subst@(tmpls,_) = uVarX tyvar2 ty1 k subst -- Predicates -uTysX (SourceTy (IParam n1 t1)) (SourceTy (IParam n2 t2)) k subst +uTysX (PredTy (IParam n1 t1)) (PredTy (IParam n2 t2)) k subst | n1 == n2 = uTysX t1 t2 k subst -uTysX (SourceTy (ClassP c1 tys1)) (SourceTy (ClassP c2 tys2)) k subst +uTysX (PredTy (ClassP c1 tys1)) (PredTy (ClassP c2 tys2)) k subst | c1 == c2 = uTyListsX tys1 tys2 k subst -uTysX (SourceTy (NType tc1 tys1)) (SourceTy (NType tc2 tys2)) k subst - | tc1 == tc2 = uTyListsX tys1 tys2 k subst -- Functions; just check the two parts uTysX (FunTy fun1 arg1) (FunTy fun2 arg2) k subst = uTysX fun1 fun2 (uTysX arg1 arg2 k) subst -- Type constructors must match +uTysX (NewTcApp tc1 tys1) (NewTcApp tc2 tys2) k subst + | tc1 == tc2 = uTyListsX tys1 tys2 k subst uTysX (TyConApp con1 tys1) (TyConApp con2 tys2) k subst | (con1 == con2 && equalLength tys1 tys2) = uTyListsX tys1 tys2 k subst @@ -1172,12 +1124,10 @@ match (TyVarTy v) ty tmpls k senv -- expect, due to an intervening Note. KSW 2000-06. -- Predicates -match (SourceTy (IParam n1 t1)) (SourceTy (IParam n2 t2)) tmpls k senv +match (PredTy (IParam n1 t1)) (PredTy (IParam n2 t2)) tmpls k senv | n1 == n2 = match t1 t2 tmpls k senv -match (SourceTy (ClassP c1 tys1)) (SourceTy (ClassP c2 tys2)) tmpls k senv +match (PredTy (ClassP c1 tys1)) (PredTy (ClassP c2 tys2)) tmpls k senv | c1 == c2 = match_list_exactly tys1 tys2 tmpls k senv -match (SourceTy (NType tc1 tys1)) (SourceTy (NType tc2 tys2)) tmpls k senv - | tc1 == tc2 = match_list_exactly tys1 tys2 tmpls k senv -- Functions; just check the two parts match (FunTy arg1 res1) (FunTy arg2 res2) tmpls k senv @@ -1188,11 +1138,10 @@ match (AppTy fun1 arg1) ty2 tmpls k senv Just (fun2,arg2) -> match fun1 fun2 tmpls (match arg1 arg2 tmpls k) senv Nothing -> Nothing -- Fail -match (TyConApp tc1 tys1) (TyConApp tc2 tys2) tmpls k senv +-- Newtypes are opaque; predicate types should not happen +match (NewTcApp tc1 tys1) (NewTcApp tc2 tys2) tmpls k senv | tc1 == tc2 = match_list_exactly tys1 tys2 tmpls k senv - --- Newtypes are opaque; other source types should not happen -match (SourceTy (NType tc1 tys1)) (SourceTy (NType tc2 tys2)) tmpls k senv +match (TyConApp tc1 tys1) (TyConApp tc2 tys2) tmpls k senv | tc1 == tc2 = match_list_exactly tys1 tys2 tmpls k senv -- With type synonyms, we have to be careful for the exact diff --git a/ghc/compiler/typecheck/TcUnify.lhs b/ghc/compiler/typecheck/TcUnify.lhs index d5323d82b9..cb4f73b32d 100644 --- a/ghc/compiler/typecheck/TcUnify.lhs +++ b/ghc/compiler/typecheck/TcUnify.lhs @@ -11,7 +11,7 @@ module TcUnify ( -- Various unifications unifyTauTy, unifyTauTyList, unifyTauTyLists, - unifyKind, unifyKinds, unifyOpenTypeKind, unifyFunKind, + unifyKind, unifyKinds, unifyTypeKind, unifyFunKind, -------------------------------- -- Holes @@ -30,12 +30,12 @@ module TcUnify ( import HsSyn ( HsExpr(..) ) import TcHsSyn ( mkHsLet, ExprCoFn, idCoercion, isIdCoercion, mkCoercion, (<.>), (<$>) ) -import TypeRep ( Type(..), SourceType(..), TyNote(..), openKindCon ) +import TypeRep ( Type(..), PredType(..), TyNote(..), typeCon, openKindCon ) import TcRnMonad -- TcType, amongst others import TcType ( TcKind, TcType, TcSigmaType, TcRhoType, TcTyVar, TcTauType, TcTyVarSet, TcThetaType, TyVarDetails(SigTv), - isTauTy, isSigmaTy, mkFunTys, + isTauTy, isSigmaTy, mkFunTys, mkTyConApp, tcSplitAppTy_maybe, tcSplitTyConApp_maybe, tcGetTyVar_maybe, tcGetTyVar, mkFunTy, tyVarsOfType, mkPhiTy, @@ -47,12 +47,12 @@ import TcType ( TcKind, TcType, TcSigmaType, TcRhoType, TcTyVar, TcTauType, ) import Inst ( newDicts, instToId, tcInstCall ) import TcMType ( getTcTyVar, putTcTyVar, tcInstType, newKindVar, - newTyVarTy, newTyVarTys, newOpenTypeKind, + newTyVarTy, newTyVarTys, newBoxityVar, zonkTcType, zonkTcTyVars, zonkTcTyVarsAndFV ) import TcSimplify ( tcSimplifyCheck ) -import TysWiredIn ( listTyCon, parrTyCon, mkListTy, mkPArrTy, mkTupleTy ) +import TysWiredIn ( listTyCon, parrTyCon, tupleTyCon ) import TcEnv ( tcGetGlobalTyVars, findGlobals ) -import TyCon ( tyConArity, isTupleTyCon, tupleTyConBoxity ) +import TyCon ( TyCon, tyConArity, isTupleTyCon, tupleTyConBoxity ) import PprType ( pprType ) import Id ( Id, mkSysLocal ) import Var ( Var, varName, tyVarKind ) @@ -185,60 +185,46 @@ unify_fun_ty_help ty -- Special cases failed, so revert to ordinary unification \end{code} \begin{code} -zapToListTy :: Expected TcType -- expected list type - -> TcM TcType -- list element type - -zapToListTy (Check ty) = unifyListTy ty -zapToListTy (Infer hole) = do { elt_ty <- newTyVarTy liftedTypeKind ; - writeMutVar hole (mkListTy elt_ty) ; +---------------------- +zapToListTy, zapToPArrTy :: Expected TcType -- expected list type + -> TcM TcType -- list element type +unifyListTy, unifyPArrTy :: TcType -> TcM TcType +zapToListTy = zapToXTy listTyCon +unifyListTy = unifyXTy listTyCon +zapToPArrTy = zapToXTy parrTyCon +unifyPArrTy = unifyXTy parrTyCon + +---------------------- +zapToXTy :: TyCon -- T :: *->* + -> Expected TcType -- Expected type (T a) + -> TcM TcType -- Element type, a + +zapToXTy tc (Check ty) = unifyXTy tc ty +zapToXTy tc (Infer hole) = do { elt_ty <- newTyVarTy liftedTypeKind ; + writeMutVar hole (mkTyConApp tc [elt_ty]) ; return elt_ty } -unifyListTy :: TcType -> TcM TcType -unifyListTy ty@(TyVarTy tyvar) +---------------------- +unifyXTy :: TyCon -> TcType -> TcM TcType +unifyXTy tc ty@(TyVarTy tyvar) = getTcTyVar tyvar `thenM` \ maybe_ty -> case maybe_ty of - Just ty' -> unifyListTy ty' - other -> unify_list_ty_help ty - -unifyListTy ty - = case tcSplitTyConApp_maybe ty of - Just (tycon, [arg_ty]) | tycon == listTyCon -> returnM arg_ty - other -> unify_list_ty_help ty - -unify_list_ty_help ty -- Revert to ordinary unification - = newTyVarTy liftedTypeKind `thenM` \ elt_ty -> - unifyTauTy ty (mkListTy elt_ty) `thenM_` - returnM elt_ty - --- variant for parallel arrays --- -zapToPArrTy :: Expected TcType -- Expected list type - -> TcM TcType -- List element type - -zapToPArrTy (Check ty) = unifyPArrTy ty -zapToPArrTy (Infer hole) = do { elt_ty <- newTyVarTy liftedTypeKind ; - writeMutVar hole (mkPArrTy elt_ty) ; - return elt_ty } + Just ty' -> unifyXTy tc ty' + other -> unify_x_ty_help tc ty -unifyPArrTy :: TcType -> TcM TcType - -unifyPArrTy ty@(TyVarTy tyvar) - = getTcTyVar tyvar `thenM` \ maybe_ty -> - case maybe_ty of - Just ty' -> unifyPArrTy ty' - _ -> unify_parr_ty_help ty -unifyPArrTy ty +unifyXTy tc ty = case tcSplitTyConApp_maybe ty of - Just (tycon, [arg_ty]) | tycon == parrTyCon -> returnM arg_ty - _ -> unify_parr_ty_help ty + Just (tycon, [arg_ty]) | tycon == tc -> returnM arg_ty + other -> unify_x_ty_help tc ty -unify_parr_ty_help ty -- Revert to ordinary unification - = newTyVarTy liftedTypeKind `thenM` \ elt_ty -> - unifyTauTy ty (mkPArrTy elt_ty) `thenM_` +unify_x_ty_help tc ty -- Revert to ordinary unification + = newTyVarTy liftedTypeKind `thenM` \ elt_ty -> + unifyTauTy ty (mkTyConApp tc [elt_ty]) `thenM_` returnM elt_ty \end{code} \begin{code} +---------------------- zapToTupleTy :: Boxity -> Arity -> Expected TcType -> TcM [TcType] zapToTupleTy boxity arity (Check ty) = unifyTupleTy boxity arity ty zapToTupleTy boxity arity (Infer hole) = do { (tup_ty, arg_tys) <- new_tuple_ty boxity arity ; @@ -267,8 +253,9 @@ unify_tuple_ty_help boxity arity ty new_tuple_ty boxity arity = newTyVarTys arity kind `thenM` \ arg_tys -> - return (mkTupleTy boxity arity arg_tys, arg_tys) + return (mkTyConApp tup_tc arg_tys, arg_tys) where + tup_tc = tupleTyCon boxity arity kind | isBoxed boxity = liftedTypeKind | otherwise = openTypeKind \end{code} @@ -626,18 +613,20 @@ uTys ps_ty1 ty1 ps_ty2 (TyVarTy tyvar2) = uVar True tyvar2 ps_ty1 ty1 -- "True" means args swapped -- Predicates -uTys _ (SourceTy (IParam n1 t1)) _ (SourceTy (IParam n2 t2)) +uTys _ (PredTy (IParam n1 t1)) _ (PredTy (IParam n2 t2)) | n1 == n2 = uTys t1 t1 t2 t2 -uTys _ (SourceTy (ClassP c1 tys1)) _ (SourceTy (ClassP c2 tys2)) +uTys _ (PredTy (ClassP c1 tys1)) _ (PredTy (ClassP c2 tys2)) | c1 == c2 = unifyTauTyLists tys1 tys2 -uTys _ (SourceTy (NType tc1 tys1)) _ (SourceTy (NType tc2 tys2)) - | tc1 == tc2 = unifyTauTyLists tys1 tys2 -- Functions; just check the two parts uTys _ (FunTy fun1 arg1) _ (FunTy fun2 arg2) = uTys fun1 fun1 fun2 fun2 `thenM_` uTys arg1 arg1 arg2 arg2 - -- Type constructors must match + -- NewType constructors must match +uTys _ (NewTcApp tc1 tys1) _ (NewTcApp tc2 tys2) + | tc1 == tc2 = unifyTauTyLists tys1 tys2 + + -- Ordinary type constructors must match uTys ps_ty1 (TyConApp con1 tys1) ps_ty2 (TyConApp con2 tys2) | con1 == con2 && equalLength tys1 tys2 = unifyTauTyLists tys1 tys2 @@ -646,7 +635,7 @@ uTys ps_ty1 (TyConApp con1 tys1) ps_ty2 (TyConApp con2 tys2) -- When we are doing kind checking, we might match a kind '?' -- against a kind '*' or '#'. Notably, CCallable :: ? -> *, and -- (CCallable Int) and (CCallable Int#) are both OK - = unifyOpenTypeKind ps_ty2 + = unifyTypeKind ps_ty2 -- Applications need a bit of care! -- They can match FunTy and TyConApp, so use splitAppTy_maybe @@ -887,8 +876,9 @@ okToUnifyWith tv ty ok (AppTy t1 t2) = ok t1 `and` ok t2 ok (FunTy t1 t2) = ok t1 `and` ok t2 ok (TyConApp _ ts) = oks ts + ok (NewTcApp _ ts) = oks ts ok (ForAllTy _ _) = Just NotMonoType - ok (SourceTy st) = ok_st st + ok (PredTy st) = ok_st st ok (NoteTy (FTVNote _) t) = ok t ok (NoteTy (SynNote t1) t2) = ok t1 `and` ok t2 -- Type variables may be free in t1 but not t2 @@ -898,7 +888,6 @@ okToUnifyWith tv ty ok_st (ClassP _ ts) = oks ts ok_st (IParam _ t) = ok t - ok_st (NType _ ts) = oks ts Nothing `and` m = m Just p `and` m = Just p @@ -924,23 +913,23 @@ unifyKinds _ _ = panic "unifyKinds: length mis-match" \end{code} \begin{code} -unifyOpenTypeKind :: TcKind -> TcM () --- Ensures that the argument kind is of the form (Type bx) --- for some boxity bx +unifyTypeKind :: TcKind -> TcM () +-- Ensures that the argument kind is a liftedTypeKind or unliftedTypeKind +-- If it's a kind variable, make it (Type bx), for a fresh boxity variable bx -unifyOpenTypeKind ty@(TyVarTy tyvar) +unifyTypeKind ty@(TyVarTy tyvar) = getTcTyVar tyvar `thenM` \ maybe_ty -> case maybe_ty of - Just ty' -> unifyOpenTypeKind ty' - other -> unify_open_kind_help ty - -unifyOpenTypeKind ty + Just ty' -> unifyTypeKind ty' + Nothing -> newBoxityVar `thenM` \ bx_var -> + putTcTyVar tyvar (mkTyConApp typeCon [bx_var]) `thenM_` + returnM () + +unifyTypeKind ty | isTypeKind ty = returnM () - | otherwise = unify_open_kind_help ty - -unify_open_kind_help ty -- Revert to ordinary unification - = newOpenTypeKind `thenM` \ open_kind -> - unifyKind ty open_kind + | otherwise -- Failure + = zonkTcType ty `thenM` \ ty1 -> + failWithTc (ptext SLIT("Type expected but") <+> quotes (ppr ty1) <+> ptext SLIT("found")) \end{code} \begin{code} diff --git a/ghc/compiler/types/Class.lhs b/ghc/compiler/types/Class.lhs index 3a37d16176..71654f87da 100644 --- a/ghc/compiler/types/Class.lhs +++ b/ghc/compiler/types/Class.lhs @@ -57,15 +57,14 @@ data Class type FunDep a = ([a],[a]) -- e.g. class C a b c | a b -> c, a c -> b where ... -- Here fun-deps are [([a,b],[c]), ([a,c],[b])] -type ClassOpItem = (Id, DefMeth Name) +type ClassOpItem = (Id, DefMeth) -- Selector function; contains unfolding -- Default-method info -data DefMeth id = NoDefMeth -- No default method - | DefMeth id -- A polymorphic default method (named id) - -- (Only instantiated to RdrName and Name, never Id) - | GenDefMeth -- A generic default method - deriving Eq +data DefMeth = NoDefMeth -- No default method + | DefMeth -- A polymorphic default method + | GenDefMeth -- A generic default method + deriving Eq \end{code} The @mkClass@ function fills in the indirect superclasses. @@ -155,6 +154,11 @@ instance Outputable Class where instance Show Class where showsPrec p c = showsPrecSDoc p (ppr c) + +instance Outputable DefMeth where + ppr DefMeth = text "{- has default method -}" + ppr GenDefMeth = text "{- has generic method -}" + ppr NoDefMeth = empty -- No default method \end{code} diff --git a/ghc/compiler/types/FunDeps.lhs b/ghc/compiler/types/FunDeps.lhs index 6fd587a205..e3023aee27 100644 --- a/ghc/compiler/types/FunDeps.lhs +++ b/ghc/compiler/types/FunDeps.lhs @@ -17,7 +17,7 @@ import Name ( getSrcLoc ) import Var ( Id, TyVar ) import Class ( Class, FunDep, classTvsFds ) import Subst ( mkSubst, emptyInScopeSet, substTy ) -import TcType ( Type, ThetaType, SourceType(..), PredType, +import TcType ( Type, ThetaType, PredType(..), predTyUnique, mkClassPred, tyVarsOfTypes, tyVarsOfPred, unifyTyListsX, unifyExtendTysX, tcEqType ) @@ -177,7 +177,7 @@ improve :: InstEnv Id -- Gives instances for given class type InstEnv a = Class -> [(TyVarSet, [Type], a)] -- This is a bit clumsy, because InstEnv is really -- defined in module InstEnv. However, we don't want --- to define it (and ClsInstEnv) here because InstEnv +-- to define it here because InstEnv -- is their home. Nor do we want to make a recursive -- module group (InstEnv imports stuff from FunDeps). \end{code} diff --git a/ghc/compiler/types/Generics.hi-boot-5 b/ghc/compiler/types/Generics.hi-boot-5 deleted file mode 100644 index 6325080257..0000000000 --- a/ghc/compiler/types/Generics.hi-boot-5 +++ /dev/null @@ -1,4 +0,0 @@ -__interface Generics 1 0 where -__export Generics mkTyConGenInfo ; - -2 mkTyConGenInfo :: TyCon.TyCon -> [Name.Name] -> PrelMaybe.Maybe (BasicTypes.EP Var.Id) ; diff --git a/ghc/compiler/types/Generics.hi-boot-6 b/ghc/compiler/types/Generics.hi-boot-6 deleted file mode 100644 index e0c5c6b58c..0000000000 --- a/ghc/compiler/types/Generics.hi-boot-6 +++ /dev/null @@ -1,4 +0,0 @@ -module Generics where - -mkTyConGenInfo :: TyCon.TyCon -> [Name.Name] - -> Data.Maybe.Maybe (BasicTypes.EP Var.Id) diff --git a/ghc/compiler/types/Generics.lhs b/ghc/compiler/types/Generics.lhs index 20bc33af6e..11f2a23a4b 100644 --- a/ghc/compiler/types/Generics.lhs +++ b/ghc/compiler/types/Generics.lhs @@ -1,43 +1,32 @@ \begin{code} -module Generics ( mkTyConGenInfo, mkGenericRhs, +module Generics ( canDoGenerics, mkGenericBinds, + mkGenericRhs, validGenericInstanceType, validGenericMethodType ) where -import RnHsSyn ( RenamedHsExpr ) -import HsSyn ( HsExpr(..), Pat(..), mkSimpleMatch, placeHolderType ) - +import HsSyn import Type ( Type, isUnLiftedType, tyVarsOfType, tyVarsOfTypes, - mkTyVarTys, mkForAllTys, mkTyConApp, - mkFunTy, isTyVarTy, getTyVar_maybe, - funTyCon + isTyVarTy, getTyVar_maybe, funTyCon ) -import TcType ( tcSplitTyConApp_maybe, tcSplitSigmaTy, tcSplitSigmaTy ) -import DataCon ( DataCon, dataConOrigArgTys, dataConWrapId, isExistentialDataCon ) +import TcType ( tcSplitTyConApp_maybe, tcSplitSigmaTy, tcSplitSigmaTy, isTauTy ) +import DataCon ( DataCon, dataConOrigArgTys, isExistentialDataCon, + dataConSourceArity ) -import TyCon ( TyCon, tyConTyVars, tyConDataCons_maybe, - tyConGenInfo, isNewTyCon, isBoxedTupleTyCon +import TyCon ( TyCon, tyConName, tyConDataCons, + tyConHasGenerics, isBoxedTupleTyCon ) -import Name ( Name, mkSystemName ) -import CoreSyn ( mkLams, Expr(..), CoreExpr, AltCon(..), - mkConApp, Alt, mkTyApps, mkVarApps ) -import CoreUtils ( exprArity ) +import Name ( nameModuleName, nameOccName, getSrcLoc ) +import OccName ( mkGenOcc1, mkGenOcc2 ) +import RdrName ( RdrName, getRdrName, mkVarUnqual, mkOrig ) import BasicTypes ( EP(..), Boxity(..) ) import Var ( TyVar ) import VarSet ( varSetElems ) -import Id ( Id, mkGlobalId, idType, idName, mkSysLocal ) -import MkId ( mkReboxingAlt, mkNewTypeBody ) -import TysWiredIn ( genericTyCons, - genUnitTyCon, genUnitDataCon, plusTyCon, inrDataCon, - inlDataCon, crossTyCon, crossDataCon - ) -import IdInfo ( GlobalIdDetails(..), noCafIdInfo, setUnfoldingInfo, setArityInfo ) -import CoreUnfold ( mkTopUnfolding ) - -import Maybe ( isNothing ) -import SrcLoc ( noSrcLoc ) -import Unique ( Unique, builtinUniques, mkBuiltinUnique ) -import Util ( takeList, dropList ) +import Id ( Id, idType ) +import PrelNames + +import SrcLoc ( generatedSrcLoc ) +import Util ( takeList ) import Outputable import FastString @@ -191,7 +180,7 @@ validGenericInstanceType :: Type -> Bool validGenericInstanceType inst_ty = case tcSplitTyConApp_maybe inst_ty of - Just (tycon, tys) -> all isTyVarTy tys && tycon `elem` genericTyCons + Just (tycon, tys) -> all isTyVarTy tys && tyConName tycon `elem` genericTyConNames Nothing -> False validGenericMethodType :: Type -> Bool @@ -228,102 +217,67 @@ validGenericMethodType ty %************************************************************************ \begin{code} -mkTyConGenInfo :: TyCon -> [Name] -> Maybe (EP Id) --- mkTyConGenInfo is called twice --- once from TysWiredIn for Tuples --- once the typechecker TcTyDecls --- to generate generic types and conversion functions for all datatypes. --- --- Must only be called with an algebraic type. --- --- The two names are the names constructed by the renamer --- for the fromT and toT conversion functions. - -mkTyConGenInfo tycon [] - = Nothing -- This happens when we deal with the interface-file type - -- decl for a module compiled without -fgenerics - -mkTyConGenInfo tycon [from_name, to_name] - | isNothing maybe_datacons -- Abstractly imported types don't have - = Nothing -- to/from operations, (and should not need them) - - -- If any of the constructor has an unboxed type as argument, +canDoGenerics :: [DataCon] -> Bool +-- Called on source-code data types, to see if we should generate +-- generic functions for them. (This info is recorded in the interface file for +-- imported data types.) + +canDoGenerics data_cons + = not (any bad_con data_cons) -- See comment below + && not (null data_cons) -- No values of the type + where + bad_con dc = any bad_arg_type (dataConOrigArgTys dc) || isExistentialDataCon dc + -- If any of the constructor has an unboxed type as argument, -- then we can't build the embedding-projection pair, because -- it relies on instantiating *polymorphic* sum and product types -- at the argument types of the constructors + -- Nor can we do the job if it's an existential data constructor, - | or [ any isUnLiftedType (dataConOrigArgTys dc) || isExistentialDataCon dc - | dc <- datacons ] - = Nothing - | null datacons -- There are no constructors; - = Nothing -- there are no values of this type + -- Nor if the args are polymorphic types (I don't think) + bad_arg_type ty = isUnLiftedType ty || not (isTauTy ty) +\end{code} - | otherwise - = ASSERT( not (null datacons) ) -- mk_sum_stuff loops if no datacons - Just (EP { fromEP = mk_id from_name from_ty from_id_info, - toEP = mk_id to_name to_ty to_id_info }) +%************************************************************************ +%* * +\subsection{Generating the RHS of a generic default method} +%* * +%************************************************************************ + +\begin{code} +type US = Int -- Local unique supply, just a plain Int +type FromAlt = (Pat RdrName, HsExpr RdrName) + +mkGenericBinds :: [TyCon] -> MonoBinds RdrName +mkGenericBinds tcs = andMonoBindList [ mkTyConGenBinds tc + | tc <- tcs, tyConHasGenerics tc] + +mkTyConGenBinds :: TyCon -> MonoBinds RdrName +mkTyConGenBinds tycon + = FunMonoBind to_RDR False {- Not infix -} + [mkSimpleHsAlt pat rhs | (pat,rhs) <- from_alts] + loc + `AndMonoBinds` + FunMonoBind from_RDR False + [mkSimpleHsAlt (VarPat to_arg) to_body] loc where - mk_id = mkGlobalId (GenericOpId tycon) - - maybe_datacons = tyConDataCons_maybe tycon - Just datacons = maybe_datacons -- [C, D] - - tyvars = tyConTyVars tycon -- [a, b, c] - tycon_ty = mkTyConApp tycon tyvar_tys -- T a b c - tyvar_tys = mkTyVarTys tyvars - - from_id_info = noCafIdInfo `setUnfoldingInfo` mkTopUnfolding from_fn - `setArityInfo` exprArity from_fn - to_id_info = noCafIdInfo `setUnfoldingInfo` mkTopUnfolding to_fn - `setArityInfo` exprArity to_fn - -- It's important to set the arity info, so that - -- the calling convention (gotten from arity) - -- matches reality. - - from_ty = mkForAllTys tyvars (mkFunTy tycon_ty rep_ty) - to_ty = mkForAllTys tyvars (mkFunTy rep_ty tycon_ty) - - (from_fn, to_fn, rep_ty) - | isNewTyCon tycon - = ( mkLams tyvars $ Lam x $ mkNewTypeBody tycon the_arg_ty (Var x), - Var (dataConWrapId the_datacon), - the_arg_ty ) - - | otherwise - = ( mkLams tyvars $ Lam x $ Case (Var x) x from_alts, - mkLams tyvars $ Lam rep_var to_inner, - idType rep_var ) - - -- x :: T a b c - x = mkGenericLocal u1 tycon_ty - (u1 : uniqs) = builtinUniques - - ---------------------- - -- Newtypes only - [the_datacon] = datacons - the_arg_ty = head (dataConOrigArgTys the_datacon) - -- NB: we use the arg type of the data constructor, rather than - -- the representation type of the newtype; in degnerate (recursive) - -- cases the rep type might be (), but the arg type is still T: - -- newtype T = MkT T - - ---------------------- - -- Non-newtypes only + loc = getSrcLoc tycon + datacons = tyConDataCons tycon + (from_RDR, to_RDR) = mkGenericNames tycon + -- Recurse over the sum first - -- The "2" is the first free unique - (from_alts, to_inner, rep_var) = mk_sum_stuff uniqs tyvars datacons - -mkTyConGenInfo tycon names = pprPanic "mkTyConGenInfo" (ppr tycon <+> ppr names) - + from_alts :: [FromAlt] + (from_alts, to_arg, to_body) = mk_sum_stuff init_us datacons + init_us = 1::Int -- Unique supply ---------------------------------------------------- -- Dealing with sums ---------------------------------------------------- -mk_sum_stuff :: [Unique] -- Base for generating unique names - -> [TyVar] -- Type variables over which the tycon is abstracted - -> [DataCon] -- The data constructors - -> ([Alt Id], CoreExpr, Id) + +mk_sum_stuff :: US -- Base for generating unique names + -> [DataCon] -- The data constructors + -> ([FromAlt], -- Alternatives for the T->Trep "from" function + RdrName, HsExpr RdrName) -- Arg and body of the Trep->T "to" function -- For example, given -- data T = C | D Int Int Int @@ -335,93 +289,85 @@ mk_sum_stuff :: [Unique] -- Base for generating unique names -- D a b c }} }, -- cd) -mk_sum_stuff us tyvars [datacon] - = ([from_alt], to_body_fn app_exp, rep_var) +mk_sum_stuff us [datacon] + = ([from_alt], to_arg, to_body_fn app_exp) where - types = dataConOrigArgTys datacon -- Existentials already excluded - datacon_vars = zipWith mkGenericLocal us types - us' = dropList types us - - app_exp = mkVarApps (Var (dataConWrapId datacon)) (tyvars ++ datacon_vars) - from_alt = mkReboxingAlt us' datacon datacon_vars from_alt_rhs - -- We are talking about *user* datacons here; hence - -- dataConWrapId - -- mkReboxingAlt - - (_,args',_) = from_alt - us'' = dropList args' us' -- Conservative, but safe - - (_, from_alt_rhs, to_body_fn, rep_var) = mk_prod_stuff us'' datacon_vars - -mk_sum_stuff (u:us) tyvars datacons - = (wrap inlDataCon l_from_alts ++ wrap inrDataCon r_from_alts, - Case (Var rep_var) rep_var [(DataAlt inlDataCon, [l_rep_var], l_to_body), - (DataAlt inrDataCon, [r_rep_var], r_to_body)], - rep_var) + n_args = dataConSourceArity datacon -- Existentials already excluded + + datacon_vars = map mkGenericLocal [us .. us+n_args-1] + us' = us + n_args + + datacon_rdr = getRdrName datacon + app_exp = mkHsVarApps datacon_rdr datacon_vars + from_alt = (mkConPat datacon_rdr datacon_vars, from_alt_rhs) + + (_, from_alt_rhs, to_arg, to_body_fn) = mk_prod_stuff us' datacon_vars + +mk_sum_stuff us datacons + = (wrap inlDataCon_RDR l_from_alts ++ wrap inrDataCon_RDR r_from_alts, + to_arg, + HsCase (HsVar to_arg) + [mkSimpleHsAlt (mkConPat inlDataCon_RDR [l_to_arg]) l_to_body, + mkSimpleHsAlt (mkConPat inrDataCon_RDR [r_to_arg]) r_to_body] + generatedSrcLoc) where - (l_datacons, r_datacons) = splitInHalf datacons - (l_from_alts, l_to_body, l_rep_var) = mk_sum_stuff us tyvars l_datacons - (r_from_alts, r_to_body, r_rep_var) = mk_sum_stuff us tyvars r_datacons - rep_tys = [idType l_rep_var, idType r_rep_var] - rep_ty = mkTyConApp plusTyCon rep_tys - rep_var = mkGenericLocal u rep_ty - - wrap :: DataCon -> [Alt Id] -> [Alt Id] + (l_datacons, r_datacons) = splitInHalf datacons + (l_from_alts, l_to_arg, l_to_body) = mk_sum_stuff us' l_datacons + (r_from_alts, r_to_arg, r_to_body) = mk_sum_stuff us' r_datacons + + to_arg = mkGenericLocal us + us' = us+1 + + wrap :: RdrName -> [FromAlt] -> [FromAlt] -- Wrap an application of the Inl or Inr constructor round each alternative - wrap datacon alts - = [(dc, args, App datacon_app rhs) | (dc,args,rhs) <- alts] - where - datacon_app = mkTyApps (Var (dataConWrapId datacon)) rep_tys + wrap dc alts = [(pat, HsApp (HsVar dc) rhs) | (pat,rhs) <- alts] + ---------------------------------------------------- -- Dealing with products ---------------------------------------------------- -mk_prod_stuff :: [Unique] -- Base for unique names - -> [Id] -- arg-ids; args of the original user-defined constructor +mk_prod_stuff :: US -- Base for unique names + -> [RdrName] -- arg-ids; args of the original user-defined constructor -- They are bound enclosing from_rhs -- Please bind these in the to_body_fn - -> ([Unique], -- Depleted unique-name supply - CoreExpr, -- from-rhs: puts together the representation from the arg_ids - CoreExpr -> CoreExpr, -- to_body_fn: takes apart the representation - Id) -- The rep-id; please bind this to the representation + -> (US, -- Depleted unique-name supply + HsExpr RdrName, -- from-rhs: puts together the representation from the arg_ids + RdrName, -- to_arg: + HsExpr RdrName -> HsExpr RdrName) -- to_body_fn: takes apart the representation -- For example: --- mk_prod_stuff [a,b,c] = ( a :*: (b :*: c), --- \x -> case abc of { a :*: bc -> --- case bc of { b :*: c -> --- x, --- abc ) +-- mk_prod_stuff abc [a,b,c] = ( a :*: (b :*: c), +-- \x -> case abc of { a :*: bc -> +-- case bc of { b :*: c -> +-- x) --- We need to use different uqiques in the branches +-- We need to use different uniques in the branches -- because the returned to_body_fns are nested. -- Hence the returned unqique-name supply -mk_prod_stuff (u:us) [] -- Unit case - = (us, - Var (dataConWrapId genUnitDataCon), - \x -> x, - mkGenericLocal u (mkTyConApp genUnitTyCon [])) +mk_prod_stuff us [] -- Unit case + = (us+1, + HsVar genUnitDataCon_RDR, + mkGenericLocal us, + \x -> x) mk_prod_stuff us [arg_var] -- Singleton case - = (us, Var arg_var, \x -> x, arg_var) + = (us, HsVar arg_var, arg_var, \x -> x) -mk_prod_stuff (u:us) arg_vars -- Two or more +mk_prod_stuff us arg_vars -- Two or more = (us'', - mkConApp crossDataCon (map Type rep_tys ++ [l_alt_rhs, r_alt_rhs]), - \x -> Case (Var rep_var) rep_var - [(DataAlt crossDataCon, [l_rep_var, r_rep_var], l_to_body_fn (r_to_body_fn x))], - rep_var) + HsVar crossDataCon_RDR `HsApp` l_alt_rhs `HsApp` r_alt_rhs, + to_arg, + \x -> HsCase (HsVar to_arg) + [mkSimpleHsAlt (mkConPat crossDataCon_RDR [l_to_arg, r_to_arg]) + (l_to_body_fn (r_to_body_fn x))] generatedSrcLoc) where - (l_arg_vars, r_arg_vars) = splitInHalf arg_vars - (us', l_alt_rhs, l_to_body_fn, l_rep_var) = mk_prod_stuff us l_arg_vars - (us'', r_alt_rhs, r_to_body_fn, r_rep_var) = mk_prod_stuff us' r_arg_vars - rep_var = mkGenericLocal u (mkTyConApp crossTyCon rep_tys) - rep_tys = [idType l_rep_var, idType r_rep_var] -\end{code} + to_arg = mkGenericLocal us + (l_arg_vars, r_arg_vars) = splitInHalf arg_vars + (us', l_alt_rhs, l_to_arg, l_to_body_fn) = mk_prod_stuff (us+1) l_arg_vars + (us'', r_alt_rhs, r_to_arg, r_to_body_fn) = mk_prod_stuff us' r_arg_vars -A little utility function -\begin{code} splitInHalf :: [a] -> ([a],[a]) splitInHalf list = (left, right) where @@ -429,8 +375,17 @@ splitInHalf list = (left, right) left = take half list right = drop half list -mkGenericLocal :: Unique -> Type -> Id -mkGenericLocal uniq ty = mkSysLocal FSLIT("g") uniq ty +mkGenericLocal :: US -> RdrName +mkGenericLocal u = mkVarUnqual (mkFastString ("g" ++ show u)) + +mkGenericNames tycon + = (from_RDR, to_RDR) + where + tc_name = tyConName tycon + tc_occ = nameOccName tc_name + tc_mod = nameModuleName tc_name + from_RDR = mkOrig tc_mod (mkGenOcc1 tc_occ) + to_RDR = mkOrig tc_mod (mkGenOcc2 tc_occ) \end{code} %************************************************************************ @@ -488,14 +443,13 @@ By the time the type checker has done its stuff we'll get op = \b. \dict::Ord b. toOp b (op Trep b dict) \begin{code} -mkGenericRhs :: Id -> TyVar -> TyCon -> RenamedHsExpr +mkGenericRhs :: Id -> TyVar -> TyCon -> HsExpr RdrName mkGenericRhs sel_id tyvar tycon - = HsApp (toEP bimap) (HsVar (idName sel_id)) + = HsApp (toEP bimap) (HsVar (getRdrName sel_id)) where -- Initialising the "Environment" with the from/to functions -- on the datatype (actually tycon) in question - Just (EP from to) = tyConGenInfo tycon -- Caller checked this will succeed - ep = EP (HsVar (idName from)) (HsVar (idName to)) + (from_RDR, to_RDR) = mkGenericNames tycon -- Takes out the ForAll and the Class restrictions -- in front of the type of the method. @@ -507,17 +461,18 @@ mkGenericRhs sel_id tyvar tycon -- Now we probably have a tycon in front -- of us, quite probably a FunTyCon. + ep = EP (HsVar from_RDR) (HsVar to_RDR) bimap = generate_bimap (tyvar, ep, local_tvs) final_ty -type EPEnv = (TyVar, -- The class type variable - EP RenamedHsExpr, -- The EP it maps to - [TyVar] -- Other in-scope tyvars; they have an identity EP +type EPEnv = (TyVar, -- The class type variable + EP (HsExpr RdrName), -- The EP it maps to + [TyVar] -- Other in-scope tyvars; they have an identity EP ) ------------------- generate_bimap :: EPEnv -> Type - -> EP RenamedHsExpr + -> EP (HsExpr RdrName) -- Top level case - splitting the TyCon. generate_bimap env@(tv,ep,local_tvs) ty = case getTyVar_maybe ty of @@ -527,7 +482,7 @@ generate_bimap env@(tv,ep,local_tvs) ty Nothing -> bimapApp env (tcSplitTyConApp_maybe ty) ------------------- -bimapApp :: EPEnv -> Maybe (TyCon, [Type]) -> EP RenamedHsExpr +bimapApp :: EPEnv -> Maybe (TyCon, [Type]) -> EP (HsExpr RdrName) bimapApp env Nothing = panic "TcClassDecl: Type Application!" bimapApp env (Just (tycon, ty_args)) | tycon == funTyCon = bimapArrow arg_eps @@ -543,32 +498,32 @@ bimapApp env (Just (tycon, ty_args)) ------------------- -- bimapArrow :: [EP a a', EP b b'] -> EP (a->b) (a'->b') bimapArrow [ep1, ep2] - = EP { fromEP = mk_hs_lam [VarPat g1, VarPat g2] from_body, - toEP = mk_hs_lam [VarPat g1, VarPat g2] to_body } + = EP { fromEP = mk_hs_lam [VarPat a_RDR, VarPat b_RDR] from_body, + toEP = mk_hs_lam [VarPat a_RDR, VarPat b_RDR] to_body } where - from_body = fromEP ep2 `HsApp` (HsPar $ HsVar g1 `HsApp` (HsPar $ toEP ep1 `HsApp` HsVar g2)) - to_body = toEP ep2 `HsApp` (HsPar $ HsVar g1 `HsApp` (HsPar $ fromEP ep1 `HsApp` HsVar g2)) + from_body = fromEP ep2 `HsApp` (HsPar $ HsVar a_RDR `HsApp` (HsPar $ toEP ep1 `HsApp` HsVar b_RDR)) + to_body = toEP ep2 `HsApp` (HsPar $ HsVar a_RDR `HsApp` (HsPar $ fromEP ep1 `HsApp` HsVar b_RDR)) ------------------- bimapTuple eps = EP { fromEP = mk_hs_lam [tuple_pat] from_body, toEP = mk_hs_lam [tuple_pat] to_body } where - names = takeList eps genericNames + names = takeList eps gs_RDR tuple_pat = TuplePat (map VarPat names) Boxed eps_w_names = eps `zip` names to_body = ExplicitTuple [toEP ep `HsApp` HsVar g | (ep,g) <- eps_w_names] Boxed from_body = ExplicitTuple [fromEP ep `HsApp` HsVar g | (ep,g) <- eps_w_names] Boxed ------------------- -genericNames :: [Name] -genericNames = [mkSystemName (mkBuiltinUnique i) (mkFastString ('g' : show i)) | i <- [1..]] -(g1:g2:g3:_) = genericNames +a_RDR = mkVarUnqual FSLIT("a") +b_RDR = mkVarUnqual FSLIT("b") +gs_RDR = [ mkVarUnqual (mkFastString ("g"++show i)) | i <- [(1::Int) .. ] ] -mk_hs_lam pats body = HsPar (HsLam (mkSimpleMatch pats body placeHolderType noSrcLoc)) +mk_hs_lam pats body = HsPar (HsLam (mkSimpleMatch pats body placeHolderType generatedSrcLoc)) -idEP :: EP RenamedHsExpr +idEP :: EP (HsExpr RdrName) idEP = EP idexpr idexpr where - idexpr = mk_hs_lam [VarPat g3] (HsVar g3) + idexpr = mk_hs_lam [VarPat a_RDR] (HsVar a_RDR) \end{code} diff --git a/ghc/compiler/types/InstEnv.lhs b/ghc/compiler/types/InstEnv.lhs index 73a6ce9734..64591bcbb0 100644 --- a/ghc/compiler/types/InstEnv.lhs +++ b/ghc/compiler/types/InstEnv.lhs @@ -7,35 +7,31 @@ The bits common to TcInstDcls and TcDeriv. \begin{code} module InstEnv ( - DFunId, ClsInstEnv, InstEnv, + DFunId, InstEnv, emptyInstEnv, extendInstEnv, pprInstEnv, - lookupInstEnv, InstLookupResult(..), - classInstEnv, simpleDFunClassTyCon + lookupInstEnv, + classInstEnv, simpleDFunClassTyCon, checkFunDeps ) where #include "HsVersions.h" import Class ( Class, classTvsFds ) -import Var ( TyVar, Id ) +import Var ( Id ) import VarSet import VarEnv -import Maybes ( MaybeErr(..), returnMaB, failMaB, thenMaB, maybeToBool ) -import Name ( getSrcLoc, nameModule ) -import SrcLoc ( SrcLoc, isGoodSrcLoc ) -import TcType ( Type, tcTyConAppTyCon, mkTyVarTy, +import TcType ( Type, tcTyConAppTyCon, tcSplitDFunTy, tyVarsOfTypes, - matchTys, unifyTyListsX, allDistinctTyVars + matchTys, unifyTyListsX ) -import PprType ( pprClassPred ) import FunDeps ( checkClsFD ) import TyCon ( TyCon ) import Outputable -import UniqFM ( UniqFM, lookupWithDefaultUFM, addToUFM, emptyUFM, eltsUFM ) -import Id ( idType, idName ) -import ErrUtils ( Message ) +import UniqFM ( UniqFM, lookupWithDefaultUFM, emptyUFM, eltsUFM, addToUFM_C ) +import Id ( idType ) import CmdLineOpts import Util ( notNull ) +import Maybe ( isJust ) \end{code} @@ -47,15 +43,25 @@ import Util ( notNull ) \begin{code} type DFunId = Id +type InstEnv = UniqFM ClsInstEnv -- Maps Class to instances for that class +type ClsInstEnv = [InstEnvElt] -- The instances for a particular class +type InstEnvElt = (TyVarSet, [Type], DFunId) + -- INVARIANTs: see notes below -type InstEnv = UniqFM ClsInstEnv -- Maps Class to instances for that class +emptyInstEnv :: InstEnv +emptyInstEnv = emptyUFM -simpleDFunClassTyCon :: DFunId -> (Class, TyCon) -simpleDFunClassTyCon dfun - = (clas, tycon) +classInstEnv :: InstEnv -> Class -> ClsInstEnv +classInstEnv env cls = lookupWithDefaultUFM env [] cls + +extendInstEnv :: InstEnv -> DFunId -> InstEnv +extendInstEnv inst_env dfun_id + = addToUFM_C add inst_env clas [ins_item] where - (_,_,clas,[ty]) = tcSplitDFunTy (idType dfun) - tycon = tcTyConAppTyCon ty + add old _ = ins_item : old + (ins_tvs, _, clas, ins_tys) = tcSplitDFunTy (idType dfun_id) + ins_tv_set = mkVarSet ins_tvs + ins_item = (ins_tv_set, ins_tys, dfun_id) pprInstEnv :: InstEnv -> SDoc pprInstEnv env @@ -64,6 +70,14 @@ pprInstEnv env | cls_inst_env <- eltsUFM env , (tyvars, tys, dfun) <- cls_inst_env ] + + +simpleDFunClassTyCon :: DFunId -> (Class, TyCon) +simpleDFunClassTyCon dfun + = (clas, tycon) + where + (_,_,clas,[ty]) = tcSplitDFunTy (idType dfun) + tycon = tcTyConAppTyCon ty \end{code} %************************************************************************ @@ -72,17 +86,6 @@ pprInstEnv env %* * %************************************************************************ -\begin{code} -type ClsInstEnv = [(TyVarSet, [Type], DFunId)] -- The instances for a particular class - -- INVARIANTs: see notes below - -emptyInstEnv :: InstEnv -emptyInstEnv = emptyUFM - -classInstEnv :: InstEnv -> Class -> ClsInstEnv -classInstEnv env cls = lookupWithDefaultUFM env [] cls -\end{code} - A @ClsInstEnv@ all the instances of that class. The @Id@ inside a ClsInstEnv mapping is the dfun for that instance. @@ -247,152 +250,91 @@ thing we are looking up can have an arbitrary "flexi" part. \begin{code} lookupInstEnv :: DynFlags - -> InstEnv -- The envt - -> Class -> [Type] -- What we are looking for - -> InstLookupResult - -data InstLookupResult - = FoundInst -- There is a (template,substitution) pair - -- that makes the template match the key, - -- and no template is an instance of the key - TyVarSubstEnv Id - - | NoMatch Bool -- Boolean is true iff there is at least one - -- template that matches the key. - -- (but there are other template(s) that are - -- instances of the key, so we don't report - -- FoundInst) - -- The NoMatch True case happens when we look up + -> (InstEnv, -- Home-package inst-env + InstEnv) -- External package inst-env + -> Class -> [Type] -- What we are looking for + -> ([(TyVarSubstEnv, InstEnvElt)], -- Successful matches + [Id]) -- These don't match but do unify + -- The second component of the tuple happens when we look up -- Foo [a] -- in an InstEnv that has entries for -- Foo [Int] -- Foo [b] -- Then which we choose would depend on the way in which 'a' - -- is instantiated. So we say there is no match, but identify - -- it as ambiguous case in the hope of giving a better error msg. - -- See the notes above from Jeff Lewis - -lookupInstEnv dflags env key_cls key_tys - = find (classInstEnv env key_cls) + -- is instantiated. So we report that Foo [b] is a match (mapping b->a) + -- but Foo [Int] is a unifier. This gives the caller a better chance of + -- giving a suitable error messagen + +lookupInstEnv dflags (home_ie, pkg_ie) cls tys + | not (null all_unifs) = (all_matches, all_unifs) -- This is always an error situation, + -- so don't attempt to pune the matches + | otherwise = (pruned_matches, []) + where + incoherent_ok = dopt Opt_AllowIncoherentInstances dflags + overlap_ok = dopt Opt_AllowOverlappingInstances dflags + (home_matches, home_unifs) = lookup_inst_env incoherent_ok home_ie cls tys + (pkg_matches, pkg_unifs) = lookup_inst_env incoherent_ok pkg_ie cls tys + all_matches = home_matches ++ pkg_matches + all_unifs = home_unifs ++ pkg_unifs + + pruned_matches | overlap_ok = foldr insert_overlapping [] all_matches + | otherwise = all_matches + +lookup_inst_env :: Bool + -> InstEnv -- The envt + -> Class -> [Type] -- What we are looking for + -> ([(TyVarSubstEnv, InstEnvElt)], -- Successful matches + [Id]) -- These don't match but do unify +lookup_inst_env incoherent_ok env key_cls key_tys + = find (classInstEnv env key_cls) [] [] where key_vars = tyVarsOfTypes key_tys - find [] = NoMatch False - find ((tpl_tyvars, tpl, dfun_id) : rest) + find [] ms us = (ms, us) + find (item@(tpl_tyvars, tpl, dfun_id) : rest) ms us = case matchTys tpl_tyvars tpl key_tys of - Nothing -> - -- Check whether the things unify, so that - -- we bale out if a later instantiation of this - -- predicate might match this instance - -- [see notes about overlapping instances above] - case unifyTyListsX (key_vars `unionVarSet` tpl_tyvars) key_tys tpl of - Just _ | not (dopt Opt_AllowIncoherentInstances dflags) - -> NoMatch (any_match rest) + Just (subst, leftovers) -> ASSERT( null leftovers ) + find rest ((subst,item):ms) us + Nothing + | incoherent_ok -> find rest ms us -- If we allow incoherent instances we don't worry about the -- test and just blaze on anyhow. Requested by John Hughes. - other -> find rest - - Just (subst, leftovers) -> ASSERT( null leftovers ) - FoundInst subst dfun_id + | otherwise + -- Does not match, so next check whether the things unify + -- [see notes about overlapping instances above] + -> case unifyTyListsX (key_vars `unionVarSet` tpl_tyvars) key_tys tpl of + Just _ -> find rest ms (dfun_id:us) + Nothing -> find rest ms us + +insert_overlapping :: (TyVarSubstEnv, InstEnvElt) -> [(TyVarSubstEnv, InstEnvElt)] + -> [(TyVarSubstEnv, InstEnvElt)] +-- Add a new solution, knocking out strictly less specific ones +insert_overlapping new_item [] = [new_item] +insert_overlapping new_item (item:items) + | new_beats_old && old_beats_new = item : insert_overlapping new_item items + -- Duplicate => keep both for error report + | new_beats_old = insert_overlapping new_item items + -- Keep new one + | old_beats_new = item : items + -- Keep old one + | otherwise = item : insert_overlapping new_item items + -- Keep both + where + new_beats_old = new_item `beats` item + old_beats_new = item `beats` new_item - any_match rest = or [ maybeToBool (matchTys tvs tpl key_tys) - | (tvs,tpl,_) <- rest - ] + (_, (tvs1, tys1, _)) `beats` (_, (tvs2, tys2, _)) + = isJust (matchTys tvs2 tys2 tys1) -- A beats B if A is more specific than B + -- I.e. if B can be instantiated to match A \end{code} %************************************************************************ %* * -\subsection{Extending an instance environment} + Functional dependencies %* * %************************************************************************ -@extendInstEnv@ extends a @ClsInstEnv@, checking for overlaps. - -A boolean flag controls overlap reporting. - -True => overlap is permitted, but only if one template matches the other; - not if they unify but neither is - -\begin{code} -extendInstEnv :: DynFlags -> InstEnv -> [DFunId] -> (InstEnv, [(SrcLoc,Message)]) - -- Similar, but all we have is the DFuns -extendInstEnv dflags env dfun_ids = foldl (addToInstEnv dflags) (env, []) dfun_ids - - -addToInstEnv :: DynFlags - -> (InstEnv, [(SrcLoc,Message)]) - -> DFunId - -> (InstEnv, [(SrcLoc,Message)]) -- Resulting InstEnv and augmented error messages - -addToInstEnv dflags (inst_env, errs) dfun_id - -- Check first that the new instance doesn't - -- conflict with another. See notes below about fundeps. - | notNull bad_fundeps - = (inst_env, fundep_err : errs) -- Bad fundeps; report the first only - - | otherwise - = case insert_into cls_inst_env of - Failed err -> (inst_env, err : errs) - Succeeded new_env -> (addToUFM inst_env clas new_env, errs) - - where - cls_inst_env = classInstEnv inst_env clas - (ins_tvs, _, clas, ins_tys) = tcSplitDFunTy (idType dfun_id) - bad_fundeps = badFunDeps cls_inst_env clas ins_tv_set ins_tys - fundep_err = fundepErr dfun_id (head bad_fundeps) - - ins_tv_set = mkVarSet ins_tvs - ins_item = (ins_tv_set, ins_tys, dfun_id) - - insert_into [] = returnMaB [ins_item] - insert_into env@(cur_item@(tpl_tvs, tpl_tys, tpl_dfun_id) : rest) - = case unifyTyListsX (ins_tv_set `unionVarSet` tpl_tvs) tpl_tys ins_tys of - Just subst -> insert_unifiable env subst - Nothing -> carry_on cur_item rest - - carry_on cur_item rest = insert_into rest `thenMaB` \ rest' -> - returnMaB (cur_item : rest') - - -- The two templates unify. This is acceptable iff - -- (a) -fallow-overlapping-instances is on - -- (b) one is strictly more specific than the other - -- [It's bad if they are identical or incomparable] - insert_unifiable env@(cur_item@(tpl_tvs, tpl_tys, tpl_dfun_id) : rest) subst - | ins_item_more_specific && cur_item_more_specific - = -- Duplicates - failMaB (dupInstErr dfun_id tpl_dfun_id) - - | not (dopt Opt_AllowOverlappingInstances dflags) - || not (ins_item_more_specific || cur_item_more_specific) - = -- Overlap illegal, or the two are incomparable - failMaB (overlapErr dfun_id tpl_dfun_id) - - | otherwise - = -- OK, it's acceptable. Remaining question is whether - -- we drop it here or compare it with others - if ins_item_more_specific then - -- New item is an instance of current item, so drop it here - returnMaB (ins_item : env) - else - carry_on cur_item rest - - where - ins_item_more_specific = allVars subst ins_tvs - cur_item_more_specific = allVars subst (varSetElems tpl_tvs) - -allVars :: TyVarSubstEnv -> [TyVar] -> Bool --- True iff all the type vars are mapped to distinct type vars -allVars subst tvs - = allDistinctTyVars (map lookup tvs) emptyVarSet - where - lookup tv = case lookupSubstEnv subst tv of - Just (DoneTy ty) -> ty - Nothing -> mkTyVarTy tv -\end{code} - -Functional dependencies -~~~~~~~~~~~~~~~~~~~~~~~ Here is the bad case: class C a b | a->b where ... instance C Int Bool where ... @@ -419,9 +361,20 @@ them separate. But we want to make sure that given any constraint if s1 matches - - \begin{code} +checkFunDeps :: (InstEnv, InstEnv) -> DFunId + -> Maybe [DFunId] -- Nothing <=> ok + -- Just dfs <=> conflict with dfs +-- Check wheher adding DFunId would break functional-dependency constraints +checkFunDeps (home_ie, pkg_ie) dfun + | null bad_fundeps = Nothing + | otherwise = Just bad_fundeps + where + (ins_tvs, _, clas, ins_tys) = tcSplitDFunTy (idType dfun) + ins_tv_set = mkVarSet ins_tvs + cls_inst_env = classInstEnv home_ie clas ++ classInstEnv pkg_ie clas + bad_fundeps = badFunDeps cls_inst_env clas ins_tv_set ins_tys + badFunDeps :: ClsInstEnv -> Class -> TyVarSet -> [Type] -- Proposed new instance type -> [DFunId] @@ -433,27 +386,3 @@ badFunDeps cls_inst_env clas ins_tv_set ins_tys where (clas_tvs, fds) = classTvsFds clas \end{code} - - -\begin{code} -dupInstErr dfun1 dfun2 = addInstErr (ptext SLIT("Duplicate instance declarations:")) dfun1 dfun2 -overlapErr dfun1 dfun2 = addInstErr (ptext SLIT("Overlapping instance declarations:")) dfun1 dfun2 -fundepErr dfun1 dfun2 = addInstErr (ptext SLIT("Functional dependencies conflict between instance declarations:")) - dfun1 dfun2 - -addInstErr :: SDoc -> DFunId -> DFunId -> (SrcLoc, Message) -addInstErr what dfun1 dfun2 - = (getSrcLoc dfun1, hang what 2 (ppr_dfun dfun1 $$ ppr_dfun dfun2)) - where - - ppr_dfun dfun = pp_loc <> colon <+> pprClassPred clas tys - where - (_,_,clas,tys) = tcSplitDFunTy (idType dfun) - loc = getSrcLoc dfun - mod = nameModule (idName dfun) - - -- Worth trying to print a good location... imported dfuns - -- don't have a useful SrcLoc but we can say which module they come from - pp_loc | isGoodSrcLoc loc = ppr loc - | otherwise = ptext SLIT("In module") <+> ppr mod -\end{code} diff --git a/ghc/compiler/types/PprType.lhs b/ghc/compiler/types/PprType.lhs index 4a04bffb55..a5a523cf3c 100644 --- a/ghc/compiler/types/PprType.lhs +++ b/ghc/compiler/types/PprType.lhs @@ -7,7 +7,7 @@ module PprType( pprKind, pprParendKind, pprType, pprParendType, - pprSourceType, pprPred, pprTheta, pprClassPred, + pprPred, pprTheta, pprThetaArrow, pprClassPred, pprTyVarBndr, pprTyVarBndrs, -- Junk @@ -18,26 +18,25 @@ module PprType( -- friends: -- (PprType can see all the representations it's trying to print) -import TypeRep ( Type(..), TyNote(..), Kind ) -- friend -import Type ( SourceType(..) ) -import TcType ( ThetaType, PredType, TyThing(..), - tcSplitSigmaTy, isPredTy, isDictTy, +import TypeRep ( Type(..), TyNote(..), PredType(..), TyThing(..), Kind, superKind ) -- friend +import Type ( typeKind, eqKind ) +import IfaceType ( toIfaceType, toIfacePred, pprParendIfaceType, + toIfaceKind, pprParendIfaceKind, + getIfaceExt ) + +import TcType ( ThetaType, PredType, + tcSplitSigmaTy, isDictTy, tcSplitTyConApp_maybe, tcSplitFunTy_maybe ) import Var ( TyVar, tyVarKind ) import Class ( Class ) -import TyCon ( TyCon, isPrimTyCon, isTupleTyCon, tupleTyConBoxity, - maybeTyConSingleCon, isEnumerationTyCon, tyConArity - ) +import TyCon ( isPrimTyCon, isTupleTyCon, maybeTyConSingleCon, isEnumerationTyCon ) -- others: import Maybes ( maybeToBool ) -import Name ( getOccString, getOccName ) -import OccName ( occNameUserString ) +import Name ( NamedThing(..), getOccString ) import Outputable -import Unique ( Uniquable(..) ) -import Util ( lengthIs ) -import BasicTypes ( IPName(..), tupleParens, ipNameName ) +import BasicTypes ( IPName(..), ipNameName ) import PrelNames -- quite a few *Keys \end{code} @@ -54,20 +53,20 @@ works just by setting the initial context precedence very high. \begin{code} pprType, pprParendType :: Type -> SDoc -pprType ty = ppr_ty tOP_PREC ty -pprParendType ty = ppr_ty tYCON_PREC ty +-- To save duplicating type-printing machinery, +-- we print a type by converting to an IfaceType and printing that +pprType ty = getIfaceExt $ \ ext -> + ppr (toIfaceType ext ty) +pprParendType ty = getIfaceExt $ \ ext -> + pprParendIfaceType (toIfaceType ext ty) pprKind, pprParendKind :: Kind -> SDoc -pprKind = pprType -pprParendKind = pprParendType +pprKind k = ppr (toIfaceKind k) +pprParendKind k = pprParendIfaceKind (toIfaceKind k) pprPred :: PredType -> SDoc -pprPred = pprSourceType - -pprSourceType :: SourceType -> SDoc -pprSourceType (ClassP clas tys) = pprClassPred clas tys -pprSourceType (IParam n ty) = hsep [ppr n, dcolon, ppr ty] -pprSourceType (NType tc tys) = ppr tc <+> sep (map pprParendType tys) +pprPred pred = getIfaceExt $ \ ext -> + ppr (toIfacePred ext pred) pprClassPred :: Class -> [Type] -> SDoc pprClassPred clas tys = ppr clas <+> sep (map pprParendType tys) @@ -75,16 +74,18 @@ pprClassPred clas tys = ppr clas <+> sep (map pprParendType tys) pprTheta :: ThetaType -> SDoc pprTheta theta = parens (sep (punctuate comma (map pprPred theta))) +pprThetaArrow :: ThetaType -> SDoc +pprThetaArrow theta + | null theta = empty + | otherwise = parens (sep (punctuate comma (map pprPred theta))) <+> ptext SLIT("=>") + instance Outputable Type where - ppr ty = pprType ty + ppr ty | typeKind ty `eqKind` superKind = pprKind ty + | otherwise = pprType ty -instance Outputable SourceType where +instance Outputable PredType where ppr = pprPred -instance Outputable name => Outputable (IPName name) where - ppr (Dupable n) = char '?' <> ppr n -- Ordinary implicit parameters - ppr (Linear n) = char '%' <> ppr n -- Splittable implicit parameters - instance Outputable name => OutputableBndr (IPName name) where pprBndr _ n = ppr n -- Simple for now @@ -93,119 +94,14 @@ instance Outputable TyThing where 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} - - -%************************************************************************ -%* * -\subsection{Pretty printing} -%* * -%************************************************************************ - -Precedence -~~~~~~~~~~ -@ppr_ty@ takes an @Int@ that is the precedence of the context. -The precedence levels are: -\begin{description} -\item[tOP_PREC] No parens required. -\item[fUN_PREC] Left hand argument of a function arrow. -\item[tYCON_PREC] Argument of a type constructor. -\end{description} - - -\begin{code} -tOP_PREC = (0 :: Int) -- type in ParseIface.y -fUN_PREC = (1 :: Int) -- btype in ParseIface.y -tYCON_PREC = (2 :: Int) -- atype in ParseIface.y -maybeParen ctxt_prec inner_prec pretty - | ctxt_prec < inner_prec = pretty - | otherwise = parens pretty +instance NamedThing TyThing where -- Can't put this with the type + getName (AnId id) = getName id -- decl, because the DataCon instance + getName (ATyCon tc) = getName tc -- isn't visible there + getName (AClass cl) = getName cl + getName (ADataCon dc) = getName dc \end{code} -\begin{code} -ppr_ty :: Int -> Type -> SDoc -ppr_ty ctxt_prec (TyVarTy tyvar) - = ppr tyvar - -ppr_ty ctxt_prec ty@(TyConApp tycon tys) - -- KIND CASE; it's of the form (Type x) - | tycon `hasKey` typeConKey, - [ty] <- tys - = -- For kinds, print (Type x) as just x if x is a - -- type constructor (must be Boxed, Unboxed, AnyBox) - -- Otherwise print as (Type x) - case ty of - TyConApp bx [] -> ppr (getOccName bx) -- Always unqualified - other -> maybeParen ctxt_prec tYCON_PREC - (ppr tycon <+> ppr_ty tYCON_PREC ty) - - -- TUPLE CASE (boxed and unboxed) - | isTupleTyCon tycon, - tys `lengthIs` tyConArity tycon -- No magic if partially applied - = tupleParens (tupleTyConBoxity tycon) - (sep (punctuate comma (map (ppr_ty tOP_PREC) tys))) - - -- LIST CASE - | tycon `hasKey` listTyConKey, - [ty] <- tys - = brackets (ppr_ty tOP_PREC ty) - - -- PARALLEL ARRAY CASE - | tycon `hasKey` parrTyConKey, - [ty] <- tys - = pabrackets (ppr_ty tOP_PREC ty) - - -- GENERAL CASE - | otherwise - = ppr_tc_app ctxt_prec tycon tys - - where - pabrackets p = ptext SLIT("[:") <> p <> ptext SLIT(":]") - - -ppr_ty ctxt_prec ty@(ForAllTy _ _) - = getPprStyle $ \ sty -> - maybeParen ctxt_prec fUN_PREC $ - sep [ ptext SLIT("forall") <+> pp_tyvars sty <> ptext SLIT("."), - ppr_theta theta, - ppr_ty tOP_PREC tau - ] - where - (tyvars, theta, tau) = tcSplitSigmaTy ty - pp_tyvars sty = sep (map pprTyVarBndr tyvars) - - ppr_theta [] = empty - ppr_theta theta = pprTheta theta <+> ptext SLIT("=>") - - -ppr_ty ctxt_prec (FunTy ty1 ty2) - -- we don't want to lose usage annotations or synonyms, - -- so we mustn't use splitFunTys here. - = maybeParen ctxt_prec fUN_PREC $ - sep [ ppr_ty fUN_PREC ty1 - , ptext arrow <+> ppr_ty tOP_PREC ty2 - ] - where arrow | isPredTy ty1 = SLIT("=>") - | otherwise = SLIT("->") - -ppr_ty ctxt_prec (AppTy ty1 ty2) - = maybeParen ctxt_prec tYCON_PREC $ - ppr_ty fUN_PREC ty1 <+> ppr_ty tYCON_PREC ty2 - -ppr_ty ctxt_prec (NoteTy (SynNote ty) expansion) - = ppr_ty ctxt_prec ty --- = ppr_ty ctxt_prec expansion -- if we don't want to see syntys - -ppr_ty ctxt_prec (NoteTy (FTVNote _) ty) = ppr_ty ctxt_prec ty - -ppr_ty ctxt_prec (SourceTy (NType tc tys)) = ppr_tc_app ctxt_prec tc tys -ppr_ty ctxt_prec (SourceTy pred) = braces (pprPred pred) - -ppr_tc_app ctxt_prec tc [] = ppr tc -ppr_tc_app ctxt_prec tc tys = maybeParen ctxt_prec tYCON_PREC - (sep [ppr tc, nest 4 (sep (map (ppr_ty tYCON_PREC) tys))]) -\end{code} %************************************************************************ @@ -251,19 +147,19 @@ getTyDescription ty TyVarTy _ -> "*" AppTy fun _ -> getTyDescription fun FunTy _ res -> '-' : '>' : fun_result res - TyConApp tycon _ -> occNameUserString (getOccName tycon) + NewTcApp tycon _ -> getOccString tycon + TyConApp tycon _ -> getOccString tycon NoteTy (FTVNote _) ty -> getTyDescription ty NoteTy (SynNote ty1) _ -> getTyDescription ty1 - SourceTy sty -> getSourceTyDescription sty + PredTy sty -> getPredTyDescription sty ForAllTy _ ty -> getTyDescription ty } where fun_result (FunTy _ res) = '>' : fun_result res fun_result other = getTyDescription other -getSourceTyDescription (ClassP cl tys) = getOccString cl -getSourceTyDescription (NType tc tys) = getOccString tc -getSourceTyDescription (IParam ip ty) = getOccString (ipNameName ip) +getPredTyDescription (ClassP cl tys) = getOccString cl +getPredTyDescription (IParam ip ty) = getOccString (ipNameName ip) \end{code} diff --git a/ghc/compiler/types/TyCon.lhs b/ghc/compiler/types/TyCon.lhs index 6f1ac543aa..9b40a448d7 100644 --- a/ghc/compiler/types/TyCon.lhs +++ b/ghc/compiler/types/TyCon.lhs @@ -14,7 +14,7 @@ module TyCon( isAlgTyCon, isDataTyCon, isSynTyCon, isNewTyCon, isPrimTyCon, isEnumerationTyCon, isTupleTyCon, isUnboxedTupleTyCon, isBoxedTupleTyCon, tupleTyConBoxity, - isRecursiveTyCon, newTyConRep, + isRecursiveTyCon, newTyConRep, isHiBootTyCon, mkForeignTyCon, isForeignTyCon, @@ -34,7 +34,7 @@ module TyCon( tyConKind, tyConUnique, tyConTyVars, - tyConArgVrcs_maybe, + tyConArgVrcs_maybe, tyConArgVrcs, tyConDataConDetails, tyConDataCons, tyConDataCons_maybe, tyConFamilySize, tyConSelIds, tyConTheta, @@ -42,13 +42,14 @@ module TyCon( tyConArity, isClassTyCon, tyConClass_maybe, getSynTyConDefn, + tyConExtName, -- External name for foreign types maybeTyConSingleCon, matchesTyCon, -- Generics - tyConGenIds, tyConGenInfo + tyConHasGenerics ) where #include "HsVersions.h" @@ -62,12 +63,11 @@ import {-# SOURCE #-} DataCon ( DataCon, isExistentialDataCon ) import Var ( TyVar, Id ) import Class ( Class ) -import BasicTypes ( Arity, RecFlag(..), Boxity(..), - isBoxed, EP(..) ) +import BasicTypes ( Arity, RecFlag(..), Boxity(..), isBoxed ) import Name ( Name, nameUnique, NamedThing(getName) ) import PrelNames ( Unique, Uniquable(..), anyBoxConKey ) import PrimRep ( PrimRep(..), isFollowableRep ) -import Maybes ( orElse ) +import Maybes ( orElse, expectJust ) import Outputable import FastString \end{code} @@ -99,7 +99,7 @@ data TyCon tyConArity :: Arity, tyConTyVars :: [TyVar], - tyConArgVrcs :: ArgVrcs, + argVrcs :: ArgVrcs, algTyConTheta :: [PredType], dataCons :: DataConDetails DataCon, @@ -110,10 +110,8 @@ data TyCon algTyConRec :: RecFlag, -- Tells whether the data type is part of -- a mutually-recursive group or not - genInfo :: Maybe (EP Id), -- Convert T <-> Tring - -- Some TyCons don't have it; - -- e.g. the TyCon for a Class dictionary, - -- and TyCons with unboxed arguments + hasGenerics :: Bool, -- True <=> generic to/from functions are available + -- (in the exports of the data type's source module) algTyConClass :: Maybe Class -- Just cl if this tycon came from a class declaration @@ -125,13 +123,13 @@ data TyCon tyConName :: Name, tyConKind :: Kind, tyConArity :: Arity, - tyConArgVrcs :: ArgVrcs, + argVrcs :: ArgVrcs, primTyConRep :: PrimRep, -- Many primitive tycons are unboxed, but some are -- boxed (represented by pointers). The PrimRep tells. isUnLifted :: Bool, -- Most primitive tycons are unlifted, -- but foreign-imported ones may not be - tyConExtName :: Maybe FastString + tyConExtName :: Maybe FastString -- Just xx for foreign-imported types } | TupleTyCon { @@ -143,7 +141,7 @@ data TyCon tyConBoxed :: Boxity, tyConTyVars :: [TyVar], dataCon :: DataCon, - genInfo :: Maybe (EP Id) -- Generic type and conv funs + hasGenerics :: Bool } | SynTyCon { @@ -156,7 +154,7 @@ data TyCon synTyConDefn :: Type, -- Right-hand side, mentioning these type vars. -- Acts as a template for the expansion when -- the tycon is applied to some types. - tyConArgVrcs :: ArgVrcs + argVrcs :: ArgVrcs } | KindCon { -- Type constructor at the kind level @@ -172,11 +170,10 @@ data TyCon } type ArgVrcs = [(Bool,Bool)] -- Tyvar variance info: [(occPos,occNeg)] + -- [] means "no information, assume the worst" data AlgTyConFlavour - = DataTyCon -- Data type - - | EnumTyCon -- Special sort of enumeration type + = DataTyCon Bool -- Data type; True <=> an enumeration type | NewTyCon Type -- Newtype, with its *ultimate* representation type -- By 'ultimate' I mean that the rep type is not itself @@ -201,10 +198,6 @@ data DataConDetails datacon | Unknown -- We're importing this data type from an hi-boot file -- and we don't know what its constructors are - | HasCons Int -- In a quest for compilation speed we have imported - -- only the number of constructors (to get return - -- conventions right) but not the constructors themselves - visibleDataCons (DataCons cs) = cs visibleDataCons other = [] \end{code} @@ -247,53 +240,41 @@ mkFunTyCon name kind tyConArity = 2 } -tyConGenInfo :: TyCon -> Maybe (EP Id) -tyConGenInfo (AlgTyCon { genInfo = info }) = info -tyConGenInfo (TupleTyCon { genInfo = info }) = info -tyConGenInfo other = Nothing - -tyConGenIds :: TyCon -> [Id] --- Returns the generic-programming Ids; these Ids need bindings -tyConGenIds tycon = case tyConGenInfo tycon of - Nothing -> [] - Just (EP from to) -> [from,to] - -- This is the making of a TyCon. Just the same as the old mkAlgTyCon, -- but now you also have to pass in the generic information about the type -- constructor - you can get hold of it easily (see Generics module) -mkAlgTyCon name kind tyvars theta argvrcs cons sels flavour is_rec - gen_info +mkAlgTyCon name kind tyvars theta argvrcs cons sels flavour is_rec gen_info = AlgTyCon { - tyConName = name, - tyConUnique = nameUnique name, - tyConKind = kind, - tyConArity = length tyvars, - tyConTyVars = tyvars, - tyConArgVrcs = argvrcs, - algTyConTheta = theta, - dataCons = cons, - selIds = sels, - algTyConClass = Nothing, - algTyConFlavour = flavour, - algTyConRec = is_rec, - genInfo = gen_info + tyConName = name, + tyConUnique = nameUnique name, + tyConKind = kind, + tyConArity = length tyvars, + tyConTyVars = tyvars, + argVrcs = argvrcs, + algTyConTheta = theta, + dataCons = cons, + selIds = sels, + algTyConClass = Nothing, + algTyConFlavour = flavour, + algTyConRec = is_rec, + hasGenerics = gen_info } mkClassTyCon name kind tyvars argvrcs con clas flavour is_rec = AlgTyCon { - tyConName = name, - tyConUnique = nameUnique name, - tyConKind = kind, - tyConArity = length tyvars, - tyConTyVars = tyvars, - tyConArgVrcs = argvrcs, - algTyConTheta = [], - dataCons = DataCons [con], - selIds = [], - algTyConClass = Just clas, - algTyConFlavour = flavour, - algTyConRec = is_rec, - genInfo = Nothing + tyConName = name, + tyConUnique = nameUnique name, + tyConKind = kind, + tyConArity = length tyvars, + tyConTyVars = tyvars, + argVrcs = argvrcs, + algTyConTheta = [], + dataCons = DataCons [con], + selIds = [], + algTyConClass = Just clas, + algTyConFlavour = flavour, + algTyConRec = is_rec, + hasGenerics = False } @@ -306,7 +287,7 @@ mkTupleTyCon name kind arity tyvars con boxed gen_info tyConBoxed = boxed, tyConTyVars = tyvars, dataCon = con, - genInfo = gen_info + hasGenerics = gen_info } -- Foreign-imported (.NET) type constructors are represented @@ -320,7 +301,7 @@ mkForeignTyCon name ext_name kind arity arg_vrcs tyConUnique = nameUnique name, tyConKind = kind, tyConArity = arity, - tyConArgVrcs = arg_vrcs, + argVrcs = arg_vrcs, primTyConRep = PtrRep, isUnLifted = False, tyConExtName = ext_name @@ -341,21 +322,21 @@ mkPrimTyCon' name kind arity arg_vrcs rep is_unlifted tyConUnique = nameUnique name, tyConKind = kind, tyConArity = arity, - tyConArgVrcs = arg_vrcs, + argVrcs = arg_vrcs, primTyConRep = rep, isUnLifted = is_unlifted, tyConExtName = Nothing } -mkSynTyCon name kind arity tyvars rhs argvrcs +mkSynTyCon name kind tyvars rhs argvrcs = SynTyCon { tyConName = name, tyConUnique = nameUnique name, tyConKind = kind, - tyConArity = arity, + tyConArity = length tyvars, tyConTyVars = tyvars, synTyConDefn = rhs, - tyConArgVrcs = argvrcs + argVrcs = argvrcs } setTyConName tc name = tc {tyConName = name, tyConUnique = nameUnique name} @@ -426,8 +407,8 @@ isSynTyCon (SynTyCon {}) = True isSynTyCon _ = False isEnumerationTyCon :: TyCon -> Bool -isEnumerationTyCon (AlgTyCon {algTyConFlavour = EnumTyCon}) = True -isEnumerationTyCon other = False +isEnumerationTyCon (AlgTyCon {algTyConFlavour = DataTyCon is_enum}) = is_enum +isEnumerationTyCon other = False isTupleTyCon :: TyCon -> Bool -- The unit tycon didn't used to be classed as a tuple tycon @@ -450,6 +431,11 @@ isRecursiveTyCon :: TyCon -> Bool isRecursiveTyCon (AlgTyCon {algTyConRec = Recursive}) = True isRecursiveTyCon other = False +isHiBootTyCon :: TyCon -> Bool +-- Used for knot-tying in hi-boot files +isHiBootTyCon (AlgTyCon {dataCons = Unknown}) = True +isHiBootTyCon other = False + isForeignTyCon :: TyCon -> Bool -- isForeignTyCon identifies foreign-imported type constructors -- For the moment, they are primitive but lifted, but that may change @@ -458,6 +444,11 @@ isForeignTyCon other = False \end{code} \begin{code} +tyConHasGenerics :: TyCon -> Bool +tyConHasGenerics (AlgTyCon {hasGenerics = hg}) = hg +tyConHasGenerics (TupleTyCon {hasGenerics = hg}) = hg +tyConHasGenerics other = False -- Synonyms + tyConDataConDetails :: TyCon -> DataConDetails DataCon tyConDataConDetails (AlgTyCon {dataCons = cons}) = cons tyConDataConDetails (TupleTyCon {dataCon = con}) = DataCons [con] @@ -475,7 +466,6 @@ tyConDataCons_maybe other = Nothing tyConFamilySize :: TyCon -> Int tyConFamilySize (AlgTyCon {dataCons = DataCons cs}) = length cs -tyConFamilySize (AlgTyCon {dataCons = HasCons n}) = n tyConFamilySize (TupleTyCon {}) = 1 #ifdef DEBUG tyConFamilySize other = pprPanic "tyConFamilySize:" (ppr other) @@ -510,14 +500,16 @@ each tyvar, if available. See @calcAlgTyConArgVrcs@ for how this is actually computed (in another file). \begin{code} -tyConArgVrcs_maybe :: TyCon -> Maybe ArgVrcs +tyConArgVrcs :: TyCon -> ArgVrcs +tyConArgVrcs tc = expectJust "tyConArgVrcs" (tyConArgVrcs_maybe tc) -tyConArgVrcs_maybe (FunTyCon {} ) = Just [(False,True),(True,False)] -tyConArgVrcs_maybe (AlgTyCon {tyConArgVrcs = oi}) = Just oi -tyConArgVrcs_maybe (PrimTyCon {tyConArgVrcs = oi}) = Just oi -tyConArgVrcs_maybe (TupleTyCon {tyConArity = arity }) = Just (replicate arity (True,False)) -tyConArgVrcs_maybe (SynTyCon {tyConArgVrcs = oi }) = Just oi -tyConArgVrcs_maybe _ = Nothing +tyConArgVrcs_maybe :: TyCon -> Maybe ArgVrcs +tyConArgVrcs_maybe (FunTyCon {}) = Just [(False,True),(True,False)] +tyConArgVrcs_maybe (AlgTyCon {argVrcs = oi}) = Just oi +tyConArgVrcs_maybe (PrimTyCon {argVrcs = oi}) = Just oi +tyConArgVrcs_maybe (TupleTyCon {tyConArity = arity}) = Just (replicate arity (True,False)) +tyConArgVrcs_maybe (SynTyCon {argVrcs = oi}) = Just oi +tyConArgVrcs_maybe _ = Nothing \end{code} \begin{code} diff --git a/ghc/compiler/types/Type.lhs b/ghc/compiler/types/Type.lhs index 96528379c4..333b589403 100644 --- a/ghc/compiler/types/Type.lhs +++ b/ghc/compiler/types/Type.lhs @@ -6,7 +6,8 @@ \begin{code} module Type ( -- re-exports from TypeRep: - Type, PredType, ThetaType, + TyThing(..), + Type, PredType(..), ThetaType, Kind, TyVarSubst, superKind, superBoxity, -- KX and BX respectively @@ -40,13 +41,14 @@ module Type ( applyTy, applyTys, isForAllTy, dropForAlls, -- Source types - SourceType(..), sourceTypeRep, mkPredTy, mkPredTys, + isPredTy, predTypeRep, mkPredTy, mkPredTys, -- Newtypes - splitNewType_maybe, + splitRecNewType_maybe, -- Lifting and boxity - isUnLiftedType, isUnboxedTupleType, isAlgType, isStrictType, isPrimitiveType, + isUnLiftedType, isUnboxedTupleType, isAlgType, isPrimitiveType, + isStrictType, isStrictPred, -- Free variables tyVarsOfType, tyVarsOfTypes, tyVarsOfPred, tyVarsOfTheta, @@ -76,11 +78,10 @@ import TypeRep -- Other imports: -import {-# SOURCE #-} PprType( pprType ) -- Only called in debug messages import {-# SOURCE #-} Subst ( substTyWith ) -- friends: -import Var ( Id, TyVar, tyVarKind, tyVarName, setTyVarName ) +import Var ( TyVar, tyVarKind, tyVarName, setTyVarName ) import VarEnv import VarSet @@ -156,22 +157,19 @@ mkTyVarTys :: [TyVar] -> [Type] mkTyVarTys = map mkTyVarTy -- a common use of mkTyVarTy getTyVar :: String -> Type -> TyVar -getTyVar msg (TyVarTy tv) = tv -getTyVar msg (SourceTy p) = getTyVar msg (sourceTypeRep p) -getTyVar msg (NoteTy _ t) = getTyVar msg t -getTyVar msg other = panic ("getTyVar: " ++ msg) - -getTyVar_maybe :: Type -> Maybe TyVar -getTyVar_maybe (TyVarTy tv) = Just tv -getTyVar_maybe (NoteTy _ t) = getTyVar_maybe t -getTyVar_maybe (SourceTy p) = getTyVar_maybe (sourceTypeRep p) -getTyVar_maybe other = Nothing +getTyVar msg ty = case getTyVar_maybe ty of + Just tv -> tv + Nothing -> panic ("getTyVar: " ++ msg) isTyVarTy :: Type -> Bool -isTyVarTy (TyVarTy tv) = True -isTyVarTy (NoteTy _ ty) = isTyVarTy ty -isTyVarTy (SourceTy p) = isTyVarTy (sourceTypeRep p) -isTyVarTy other = False +isTyVarTy ty = isJust (getTyVar_maybe ty) + +getTyVar_maybe :: Type -> Maybe TyVar +getTyVar_maybe (TyVarTy tv) = Just tv +getTyVar_maybe (NoteTy _ t) = getTyVar_maybe t +getTyVar_maybe (PredTy p) = getTyVar_maybe (predTypeRep p) +getTyVar_maybe (NewTcApp tc tys) = getTyVar_maybe (newTypeRep tc tys) +getTyVar_maybe other = Nothing \end{code} @@ -184,10 +182,11 @@ invariant: use it. \begin{code} mkAppTy orig_ty1 orig_ty2 - = ASSERT( not (isSourceTy orig_ty1) ) -- Source types are of kind * + = ASSERT2( not (isPredTy orig_ty1), crudePprType orig_ty1 ) -- Source types are of kind * mk_app orig_ty1 where mk_app (NoteTy _ ty1) = mk_app ty1 + mk_app (NewTcApp tc tys) = NewTcApp tc (tys ++ [orig_ty2]) mk_app (TyConApp tc tys) = mkGenTyConApp tc (tys ++ [orig_ty2]) mk_app ty1 = AppTy orig_ty1 orig_ty2 -- We call mkGenTyConApp because the TyConApp could be an @@ -207,21 +206,26 @@ mkAppTys orig_ty1 [] = orig_ty1 -- returns to (Ratio Integer), which has needlessly lost -- the Rational part. mkAppTys orig_ty1 orig_tys2 - = ASSERT( not (isSourceTy orig_ty1) ) -- Source types are of kind * + = ASSERT( not (isPredTy orig_ty1) ) -- Source types are of kind * mk_app orig_ty1 where mk_app (NoteTy _ ty1) = mk_app ty1 + mk_app (NewTcApp tc tys) = NewTcApp tc (tys ++ orig_tys2) mk_app (TyConApp tc tys) = mkTyConApp tc (tys ++ orig_tys2) + -- Use mkTyConApp in case tc is (->) mk_app ty1 = foldl AppTy orig_ty1 orig_tys2 splitAppTy_maybe :: Type -> Maybe (Type, Type) splitAppTy_maybe (FunTy ty1 ty2) = Just (TyConApp funTyCon [ty1], ty2) splitAppTy_maybe (AppTy ty1 ty2) = Just (ty1, ty2) splitAppTy_maybe (NoteTy _ ty) = splitAppTy_maybe ty -splitAppTy_maybe (SourceTy p) = splitAppTy_maybe (sourceTypeRep p) +splitAppTy_maybe (PredTy p) = splitAppTy_maybe (predTypeRep p) +splitAppTy_maybe (NewTcApp tc tys) = splitAppTy_maybe (newTypeRep tc tys) splitAppTy_maybe (TyConApp tc tys) = case snocView tys of Nothing -> Nothing - Just (tys',ty') -> Just (TyConApp tc tys', ty') + Just (tys',ty') -> Just (mkGenTyConApp tc tys', ty') + -- mkGenTyConApp just in case the tc is a newtype + splitAppTy_maybe other = Nothing splitAppTy :: Type -> (Type, Type) @@ -234,10 +238,12 @@ splitAppTys ty = split ty ty [] where split orig_ty (AppTy ty arg) args = split ty ty (arg:args) split orig_ty (NoteTy _ ty) args = split orig_ty ty args - split orig_ty (SourceTy p) args = split orig_ty (sourceTypeRep p) args + split orig_ty (PredTy p) args = split orig_ty (predTypeRep p) args + split orig_ty (NewTcApp tc tc_args) args = split orig_ty (newTypeRep tc tc_args) args + split orig_ty (TyConApp tc tc_args) args = (mkGenTyConApp tc [], tc_args ++ args) + -- mkGenTyConApp just in case the tc is a newtype split orig_ty (FunTy ty1 ty2) args = ASSERT( null args ) (TyConApp funTyCon [], [ty1,ty2]) - split orig_ty (TyConApp tc tc_args) args = (TyConApp tc [], tc_args ++ args) split orig_ty ty args = (orig_ty, args) \end{code} @@ -257,51 +263,58 @@ isFunTy :: Type -> Bool isFunTy ty = isJust (splitFunTy_maybe ty) splitFunTy :: Type -> (Type, Type) -splitFunTy (FunTy arg res) = (arg, res) -splitFunTy (NoteTy _ ty) = splitFunTy ty -splitFunTy (SourceTy p) = splitFunTy (sourceTypeRep p) +splitFunTy (FunTy arg res) = (arg, res) +splitFunTy (NoteTy _ ty) = splitFunTy ty +splitFunTy (PredTy p) = splitFunTy (predTypeRep p) +splitFunTy (NewTcApp tc tys) = splitFunTy (newTypeRep tc tys) +splitFunTy other = pprPanic "splitFunTy" (crudePprType other) splitFunTy_maybe :: Type -> Maybe (Type, Type) -splitFunTy_maybe (FunTy arg res) = Just (arg, res) -splitFunTy_maybe (NoteTy _ ty) = splitFunTy_maybe ty -splitFunTy_maybe (SourceTy p) = splitFunTy_maybe (sourceTypeRep p) -splitFunTy_maybe other = Nothing +splitFunTy_maybe (FunTy arg res) = Just (arg, res) +splitFunTy_maybe (NoteTy _ ty) = splitFunTy_maybe ty +splitFunTy_maybe (PredTy p) = splitFunTy_maybe (predTypeRep p) +splitFunTy_maybe (NewTcApp tc tys) = splitFunTy_maybe (newTypeRep tc tys) +splitFunTy_maybe other = Nothing splitFunTys :: Type -> ([Type], Type) splitFunTys ty = split [] ty ty where - split args orig_ty (FunTy arg res) = split (arg:args) res res - split args orig_ty (NoteTy _ ty) = split args orig_ty ty - split args orig_ty (SourceTy p) = split args orig_ty (sourceTypeRep p) - split args orig_ty ty = (reverse args, orig_ty) + split args orig_ty (FunTy arg res) = split (arg:args) res res + split args orig_ty (NoteTy _ ty) = split args orig_ty ty + split args orig_ty (PredTy p) = split args orig_ty (predTypeRep p) + split args orig_ty (NewTcApp tc tys) = split args orig_ty (newTypeRep tc tys) + split args orig_ty ty = (reverse args, orig_ty) zipFunTys :: Outputable a => [a] -> Type -> ([(a,Type)], Type) zipFunTys orig_xs orig_ty = split [] orig_xs orig_ty orig_ty where - split acc [] nty ty = (reverse acc, nty) - split acc (x:xs) nty (FunTy arg res) = split ((x,arg):acc) xs res res - split acc xs nty (NoteTy _ ty) = split acc xs nty ty - split acc xs nty (SourceTy p) = split acc xs nty (sourceTypeRep p) - split acc (x:xs) nty ty = pprPanic "zipFunTys" (ppr orig_xs <+> pprType orig_ty) + split acc [] nty ty = (reverse acc, nty) + split acc (x:xs) nty (FunTy arg res) = split ((x,arg):acc) xs res res + split acc xs nty (NoteTy _ ty) = split acc xs nty ty + split acc xs nty (PredTy p) = split acc xs nty (predTypeRep p) + split acc xs nty (NewTcApp tc tys) = split acc xs nty (newTypeRep tc tys) + split acc (x:xs) nty ty = pprPanic "zipFunTys" (ppr orig_xs <+> crudePprType orig_ty) funResultTy :: Type -> Type -funResultTy (FunTy arg res) = res -funResultTy (NoteTy _ ty) = funResultTy ty -funResultTy (SourceTy p) = funResultTy (sourceTypeRep p) -funResultTy ty = pprPanic "funResultTy" (pprType ty) +funResultTy (FunTy arg res) = res +funResultTy (NoteTy _ ty) = funResultTy ty +funResultTy (PredTy p) = funResultTy (predTypeRep p) +funResultTy (NewTcApp tc tys) = funResultTy (newTypeRep tc tys) +funResultTy ty = pprPanic "funResultTy" (crudePprType ty) funArgTy :: Type -> Type -funArgTy (FunTy arg res) = arg -funArgTy (NoteTy _ ty) = funArgTy ty -funArgTy (SourceTy p) = funArgTy (sourceTypeRep p) -funArgTy ty = pprPanic "funArgTy" (pprType ty) +funArgTy (FunTy arg res) = arg +funArgTy (NoteTy _ ty) = funArgTy ty +funArgTy (PredTy p) = funArgTy (predTypeRep p) +funArgTy (NewTcApp tc tys) = funArgTy (newTypeRep tc tys) +funArgTy ty = pprPanic "funArgTy" (crudePprType ty) \end{code} --------------------------------------------------------------------- TyConApp ~~~~~~~~ -@mkTyConApp@ is a key function, because it builds a TyConApp, FunTy or SourceTy, +@mkTyConApp@ is a key function, because it builds a TyConApp, FunTy or PredTy, as apppropriate. \begin{code} @@ -316,18 +329,15 @@ mkTyConApp tycon tys | isFunTyCon tycon, [ty1,ty2] <- tys = FunTy ty1 ty2 - | isNewTyCon tycon, -- A saturated newtype application; - not (isRecursiveTyCon tycon), -- Not recursive (we don't use SourceTypes for them) - tys `lengthIs` tyConArity tycon -- use the SourceType form - = SourceTy (NType tycon tys) + | isNewTyCon tycon + = NewTcApp tycon tys | otherwise = ASSERT(not (isSynTyCon tycon)) TyConApp tycon tys mkTyConTy :: TyCon -> Type -mkTyConTy tycon = ASSERT( not (isSynTyCon tycon) ) - TyConApp tycon [] +mkTyConTy tycon = mkTyConApp tycon [] -- splitTyConApp "looks through" synonyms, because they don't -- mean a distinct type, but all other type-constructor applications @@ -342,13 +352,14 @@ tyConAppArgs ty = snd (splitTyConApp ty) splitTyConApp :: Type -> (TyCon, [Type]) splitTyConApp ty = case splitTyConApp_maybe ty of Just stuff -> stuff - Nothing -> pprPanic "splitTyConApp" (pprType ty) + Nothing -> pprPanic "splitTyConApp" (crudePprType ty) splitTyConApp_maybe :: Type -> Maybe (TyCon, [Type]) splitTyConApp_maybe (TyConApp tc tys) = Just (tc, tys) splitTyConApp_maybe (FunTy arg res) = Just (funTyCon, [arg,res]) splitTyConApp_maybe (NoteTy _ ty) = splitTyConApp_maybe ty -splitTyConApp_maybe (SourceTy p) = splitTyConApp_maybe (sourceTypeRep p) +splitTyConApp_maybe (PredTy p) = splitTyConApp_maybe (predTypeRep p) +splitTyConApp_maybe (NewTcApp tc tys) = splitTyConApp_maybe (newTypeRep tc tys) splitTyConApp_maybe other = Nothing \end{code} @@ -408,17 +419,14 @@ repType looks through (e) [recursive] newtypes It's useful in the back end. -Remember, non-recursive newtypes get expanded as part of the SourceTy case, -but recursive ones are represented by TyConApps and have to be expanded -by steam. - \begin{code} repType :: Type -> Type +-- Only applied to types of kind *; hence tycons are saturated repType (ForAllTy _ ty) = repType ty repType (NoteTy _ ty) = repType ty -repType (SourceTy p) = repType (sourceTypeRep p) -repType (TyConApp tc tys) | isNewTyCon tc && tys `lengthIs` tyConArity tc - = repType (newTypeRep tc tys) +repType (PredTy p) = repType (predTypeRep p) +repType (NewTcApp tc tys) = ASSERT( tys `lengthIs` tyConArity tc ) + repType (new_type_rep tc tys) repType ty = ty @@ -428,6 +436,7 @@ typePrimRep ty = case repType ty of FunTy _ _ -> PtrRep AppTy _ _ -> PtrRep -- ?? TyVarTy _ -> PtrRep + other -> pprPanic "typePrimRep" (crudePprType ty) \end{code} @@ -453,17 +462,19 @@ splitForAllTy_maybe :: Type -> Maybe (TyVar, Type) splitForAllTy_maybe ty = splitFAT_m ty where splitFAT_m (NoteTy _ ty) = splitFAT_m ty - splitFAT_m (SourceTy p) = splitFAT_m (sourceTypeRep p) + splitFAT_m (PredTy p) = splitFAT_m (predTypeRep p) + splitFAT_m (NewTcApp tc tys) = splitFAT_m (newTypeRep tc tys) splitFAT_m (ForAllTy tyvar ty) = Just(tyvar, ty) splitFAT_m _ = Nothing splitForAllTys :: Type -> ([TyVar], Type) splitForAllTys ty = split ty ty [] where - split orig_ty (ForAllTy tv ty) tvs = split ty ty (tv:tvs) - split orig_ty (NoteTy _ ty) tvs = split orig_ty ty tvs - split orig_ty (SourceTy p) tvs = split orig_ty (sourceTypeRep p) tvs - split orig_ty t tvs = (reverse tvs, orig_ty) + split orig_ty (ForAllTy tv ty) tvs = split ty ty (tv:tvs) + split orig_ty (NoteTy _ ty) tvs = split orig_ty ty tvs + split orig_ty (PredTy p) tvs = split orig_ty (predTypeRep p) tvs + split orig_ty (NewTcApp tc tys) tvs = split orig_ty (newTypeRep tc tys) tvs + split orig_ty t tvs = (reverse tvs, orig_ty) dropForAlls :: Type -> Type dropForAlls ty = snd (splitForAllTys ty) @@ -481,10 +492,11 @@ the expression. \begin{code} applyTy :: Type -> Type -> Type -applyTy (SourceTy p) arg = applyTy (sourceTypeRep p) arg -applyTy (NoteTy _ fun) arg = applyTy fun arg -applyTy (ForAllTy tv ty) arg = substTyWith [tv] [arg] ty -applyTy other arg = panic "applyTy" +applyTy (PredTy p) arg = applyTy (predTypeRep p) arg +applyTy (NewTcApp tc tys) arg = applyTy (newTypeRep tc tys) arg +applyTy (NoteTy _ fun) arg = applyTy fun arg +applyTy (ForAllTy tv ty) arg = substTyWith [tv] [arg] ty +applyTy other arg = panic "applyTy" applyTys :: Type -> [Type] -> Type -- This function is interesting because @@ -506,7 +518,7 @@ applyTys orig_fun_ty arg_tys = substTyWith (take n_args tvs) arg_tys (mkForAllTys (drop n_args tvs) rho_ty) | otherwise -- Too many type args - = ASSERT2( n_tvs > 0, pprType orig_fun_ty ) -- Zero case gives infnite loop! + = ASSERT2( n_tvs > 0, crudePprType orig_fun_ty ) -- Zero case gives infnite loop! applyTys (substTyWith tvs (take n_tvs arg_tys) rho_ty) (drop n_tvs arg_tys) where @@ -527,46 +539,75 @@ concerned, but which has low-level representation as far as the back end is conc Source types are always lifted. -The key function is sourceTypeRep which gives the representation of a source type: +The key function is predTypeRep which gives the representation of a source type: \begin{code} mkPredTy :: PredType -> Type -mkPredTy pred = SourceTy pred +mkPredTy pred = PredTy pred mkPredTys :: ThetaType -> [Type] -mkPredTys preds = map SourceTy preds - -sourceTypeRep :: SourceType -> Type --- Convert a predicate to its "representation type"; --- the type of evidence for that predicate, which is actually passed at runtime -sourceTypeRep (IParam _ ty) = ty -sourceTypeRep (ClassP clas tys) = mkTyConApp (classTyCon clas) tys - -- Note the mkTyConApp; the classTyCon might be a newtype! -sourceTypeRep (NType tc tys) = newTypeRep tc tys - -- ToDo: Consider caching this substitution in a NType - -isSourceTy :: Type -> Bool -isSourceTy (NoteTy _ ty) = isSourceTy ty -isSourceTy (SourceTy sty) = True -isSourceTy _ = False +mkPredTys preds = map PredTy preds + +predTypeRep :: PredType -> Type +-- Convert a PredType to its "representation type"; +-- the post-type-checking type used by all the Core passes of GHC. +predTypeRep (IParam _ ty) = ty +predTypeRep (ClassP clas tys) = mkTyConApp (classTyCon clas) tys + -- Result might be a NewTcApp, but the consumer will + -- look through that too if necessary + +isPredTy :: Type -> Bool +isPredTy (NoteTy _ ty) = isPredTy ty +isPredTy (PredTy sty) = True +isPredTy _ = False +\end{code} -splitNewType_maybe :: Type -> Maybe Type --- Newtypes that are recursive are reprsented by TyConApp, just --- as they always were. Occasionally we want to find their representation type. --- NB: remember that in this module, non-recursive newtypes are transparent +%************************************************************************ +%* * + NewTypes +%* * +%************************************************************************ -splitNewType_maybe ty - = case splitTyConApp_maybe ty of - Just (tc,tys) | isNewTyCon tc -> ASSERT( tys `lengthIs` tyConArity tc ) - -- The assert should hold because repType should - -- only be applied to *types* (of kind *) - Just (newTypeRep tc tys) - other -> Nothing +\begin{code} +splitRecNewType_maybe :: Type -> Maybe Type +-- Newtypes are always represented by a NewTcApp +-- Sometimes we want to look through a recursive newtype, and that's what happens here +-- Only applied to types of kind *, hence the newtype is always saturated +splitRecNewType_maybe (NoteTy _ ty) = splitRecNewType_maybe ty +splitRecNewType_maybe (NewTcApp tc tys) + | isRecursiveTyCon tc + = ASSERT( tys `lengthIs` tyConArity tc && isNewTyCon tc ) + -- The assert should hold because repType should + -- only be applied to *types* (of kind *) + Just (new_type_rep tc tys) +splitRecNewType_maybe other = Nothing +----------------------------- +newTypeRep :: TyCon -> [Type] -> Type -- A local helper function (not exported) -newTypeRep new_tycon tys = case newTyConRep new_tycon of - (tvs, rep_ty) -> substTyWith tvs tys rep_ty +-- Expands a newtype application to +-- *either* a vanilla TyConApp (recursive newtype, or non-saturated) +-- *or* the newtype representation (otherwise) +-- Either way, the result is not a NewTcApp +-- +-- NB: the returned TyConApp is always deconstructed immediately by the +-- caller... a TyConApp with a newtype type constructor never lives +-- in an ordinary type +newTypeRep tc tys + | not (isRecursiveTyCon tc), -- Not recursive and saturated + tys `lengthIs` tyConArity tc -- treat as equivalent to expansion + = new_type_rep tc tys + | otherwise + = TyConApp tc tys + -- ToDo: Consider caching this substitution in a NType + +---------------------------- +-- new_type_rep doesn't ask any questions: +-- it just expands newtype, whether recursive or not +new_type_rep new_tycon tys = ASSERT( tys `lengthIs` tyConArity new_tycon ) + case newTyConRep new_tycon of + (tvs, rep_ty) -> substTyWith tvs tys rep_ty \end{code} @@ -584,8 +625,9 @@ typeKind :: Type -> Kind typeKind (TyVarTy tyvar) = tyVarKind tyvar typeKind (TyConApp tycon tys) = foldr (\_ k -> funResultTy k) (tyConKind tycon) tys +typeKind (NewTcApp tycon tys) = foldr (\_ k -> funResultTy k) (tyConKind tycon) tys typeKind (NoteTy _ ty) = typeKind ty -typeKind (SourceTy _) = liftedTypeKind -- Predicates are always +typeKind (PredTy _) = liftedTypeKind -- Predicates are always -- represented by lifted types typeKind (AppTy fun arg) = funResultTy (typeKind fun) @@ -613,9 +655,10 @@ typeKind (ForAllTy tv ty) = typeKind ty tyVarsOfType :: Type -> TyVarSet tyVarsOfType (TyVarTy tv) = unitVarSet tv tyVarsOfType (TyConApp tycon tys) = tyVarsOfTypes tys +tyVarsOfType (NewTcApp tycon tys) = tyVarsOfTypes tys tyVarsOfType (NoteTy (FTVNote tvs) ty2) = tvs tyVarsOfType (NoteTy (SynNote ty1) ty2) = tyVarsOfType ty2 -- See note [Syn] below -tyVarsOfType (SourceTy sty) = tyVarsOfSourceType sty +tyVarsOfType (PredTy sty) = tyVarsOfPred sty tyVarsOfType (FunTy arg res) = tyVarsOfType arg `unionVarSet` tyVarsOfType res tyVarsOfType (AppTy fun arg) = tyVarsOfType fun `unionVarSet` tyVarsOfType arg tyVarsOfType (ForAllTy tyvar ty) = tyVarsOfType ty `minusVarSet` unitVarSet tyvar @@ -639,15 +682,11 @@ tyVarsOfTypes :: [Type] -> TyVarSet tyVarsOfTypes tys = foldr (unionVarSet.tyVarsOfType) emptyVarSet tys tyVarsOfPred :: PredType -> TyVarSet -tyVarsOfPred = tyVarsOfSourceType -- Just a subtype - -tyVarsOfSourceType :: SourceType -> TyVarSet -tyVarsOfSourceType (IParam _ ty) = tyVarsOfType ty -tyVarsOfSourceType (ClassP _ tys) = tyVarsOfTypes tys -tyVarsOfSourceType (NType _ tys) = tyVarsOfTypes tys +tyVarsOfPred (IParam _ ty) = tyVarsOfType ty +tyVarsOfPred (ClassP _ tys) = tyVarsOfTypes tys tyVarsOfTheta :: ThetaType -> TyVarSet -tyVarsOfTheta = foldr (unionVarSet . tyVarsOfSourceType) emptyVarSet +tyVarsOfTheta = foldr (unionVarSet . tyVarsOfPred) emptyVarSet -- Add a Note with the free tyvars to the top of the type addFreeTyVars :: Type -> Type @@ -705,8 +744,10 @@ tidyType env@(tidy_env, subst) ty Just tv' -> TyVarTy tv' go (TyConApp tycon tys) = let args = map go tys in args `seqList` TyConApp tycon args + go (NewTcApp tycon tys) = let args = map go tys + in args `seqList` NewTcApp tycon args go (NoteTy note ty) = (NoteTy $! (go_note note)) $! (go ty) - go (SourceTy sty) = SourceTy (tidySourceType env sty) + go (PredTy sty) = PredTy (tidyPred env sty) go (AppTy fun arg) = (AppTy $! (go fun)) $! (go arg) go (FunTy fun arg) = (FunTy $! (go fun)) $! (go arg) go (ForAllTy tv ty) = ForAllTy tvp $! (tidyType envp ty) @@ -718,13 +759,9 @@ tidyType env@(tidy_env, subst) ty tidyTypes env tys = map (tidyType env) tys -tidyPred :: TidyEnv -> SourceType -> SourceType -tidyPred = tidySourceType - -tidySourceType :: TidyEnv -> SourceType -> SourceType -tidySourceType env (IParam n ty) = IParam n (tidyType env ty) -tidySourceType env (ClassP clas tys) = ClassP clas (tidyTypes env tys) -tidySourceType env (NType tc tys) = NType tc (tidyTypes env tys) +tidyPred :: TidyEnv -> PredType -> PredType +tidyPred env (IParam n ty) = IParam n (tidyType env ty) +tidyPred env (ClassP clas tys) = ClassP clas (tidyTypes env tys) \end{code} @@ -761,11 +798,12 @@ isUnLiftedType :: Type -> Bool -- They are pretty bogus types, mind you. It would be better never to -- construct them -isUnLiftedType (ForAllTy tv ty) = isUnLiftedType ty -isUnLiftedType (NoteTy _ ty) = isUnLiftedType ty -isUnLiftedType (TyConApp tc _) = isUnLiftedTyCon tc -isUnLiftedType (SourceTy _) = False -- All source types are lifted -isUnLiftedType other = False +isUnLiftedType (ForAllTy tv ty) = isUnLiftedType ty +isUnLiftedType (NoteTy _ ty) = isUnLiftedType ty +isUnLiftedType (TyConApp tc _) = isUnLiftedTyCon tc +isUnLiftedType (PredTy _) = False -- All source types are lifted +isUnLiftedType (NewTcApp tc tys) = isUnLiftedType (newTypeRep tc tys) +isUnLiftedType other = False isUnboxedTupleType :: Type -> Bool isUnboxedTupleType ty = case splitTyConApp_maybe ty of @@ -788,15 +826,19 @@ this function should be in TcType, but isStrictType is used by DataCon, which is below TcType in the hierarchy, so it's convenient to put it here. \begin{code} -isStrictType (ForAllTy tv ty) = isStrictType ty -isStrictType (NoteTy _ ty) = isStrictType ty -isStrictType (TyConApp tc _) = isUnLiftedTyCon tc -isStrictType (SourceTy (ClassP clas _)) = opt_DictsStrict && not (isNewTyCon (classTyCon clas)) +isStrictType (ForAllTy tv ty) = isStrictType ty +isStrictType (NoteTy _ ty) = isStrictType ty +isStrictType (TyConApp tc _) = isUnLiftedTyCon tc +isStrictType (NewTcApp tc tys) = isStrictType (newTypeRep tc tys) +isStrictType (PredTy pred) = isStrictPred pred +isStrictType other = False + +isStrictPred (ClassP clas _) = opt_DictsStrict && not (isNewTyCon (classTyCon clas)) +isStrictPred other = False -- We may be strict in dictionary types, but only if it -- has more than one component. -- [Being strict in a single-component dictionary risks -- poking the dictionary component, which is wrong.] -isStrictType other = False \end{code} \begin{code} @@ -823,8 +865,9 @@ seqType (TyVarTy tv) = tv `seq` () seqType (AppTy t1 t2) = seqType t1 `seq` seqType t2 seqType (FunTy t1 t2) = seqType t1 `seq` seqType t2 seqType (NoteTy note t2) = seqNote note `seq` seqType t2 -seqType (SourceTy p) = seqPred p +seqType (PredTy p) = seqPred p seqType (TyConApp tc tys) = tc `seq` seqTypes tys +seqType (NewTcApp tc tys) = tc `seq` seqTypes tys seqType (ForAllTy tv ty) = tv `seq` seqType ty seqTypes :: [Type] -> () @@ -835,9 +878,8 @@ seqNote :: TyNote -> () seqNote (SynNote ty) = seqType ty seqNote (FTVNote set) = sizeUniqSet set `seq` () -seqPred :: SourceType -> () +seqPred :: PredType -> () seqPred (ClassP c tys) = c `seq` seqTypes tys -seqPred (NType tc tys) = tc `seq` seqTypes tys seqPred (IParam n ty) = n `seq` seqType ty \end{code} @@ -869,9 +911,31 @@ eqKind = eqType -- No worries about looking eq_ty env (NoteTy _ t1) t2 = eq_ty env t1 t2 eq_ty env t1 (NoteTy _ t2) = eq_ty env t1 t2 --- Look through SourceTy. This is where the looping danger comes from -eq_ty env (SourceTy sty1) t2 = eq_ty env (sourceTypeRep sty1) t2 -eq_ty env t1 (SourceTy sty2) = eq_ty env t1 (sourceTypeRep sty2) +-- Look through PredTy and NewTcApp. This is where the looping danger comes from. +-- We don't bother to check for the PredType/PredType case, no good reason +-- Hmm: maybe there is a good reason: see the notes below about newtypes +eq_ty env (PredTy sty1) t2 = eq_ty env (predTypeRep sty1) t2 +eq_ty env t1 (PredTy sty2) = eq_ty env t1 (predTypeRep sty2) + +-- NB: we *cannot* short-cut the newtype comparison thus: +-- eq_ty env (NewTcApp tc1 tys1) (NewTcApp tc2 tys2) +-- | (tc1 == tc2) = (eq_tys env tys1 tys2) +-- +-- Consider: +-- newtype T a = MkT [a] +-- newtype Foo m = MkFoo (forall a. m a -> Int) +-- w1 :: Foo [] +-- w1 = ... +-- +-- w2 :: Foo T +-- w2 = MkFoo (\(MkT x) -> case w1 of MkFoo f -> f x) +-- +-- We end up with w2 = w1; so we need that Foo T = Foo [] +-- but we can only expand saturated newtypes, so just comparing +-- T with [] won't do. + +eq_ty env (NewTcApp tc1 tys1) t2 = eq_ty env (newTypeRep tc1 tys1) t2 +eq_ty env t1 (NewTcApp tc2 tys2) = eq_ty env t1 (newTypeRep tc2 tys2) -- The rest is plain sailing eq_ty env (TyVarTy tv1) (TyVarTy tv2) = case lookupVarEnv env tv1 of diff --git a/ghc/compiler/types/TypeRep.hi-boot-6 b/ghc/compiler/types/TypeRep.hi-boot-6 index 5fdbdf5bf2..c66df6f552 100644 --- a/ghc/compiler/types/TypeRep.hi-boot-6 +++ b/ghc/compiler/types/TypeRep.hi-boot-6 @@ -2,6 +2,8 @@ module TypeRep where data Type data SourceType +data TyThing + type PredType = SourceType type Kind = Type type SuperKind = Type diff --git a/ghc/compiler/types/TypeRep.lhs b/ghc/compiler/types/TypeRep.lhs index 7447e88fd6..1c74dc1b3e 100644 --- a/ghc/compiler/types/TypeRep.lhs +++ b/ghc/compiler/types/TypeRep.lhs @@ -5,10 +5,11 @@ \begin{code} module TypeRep ( + TyThing(..), Type(..), TyNote(..), -- Representation visible - SourceType(..), -- to friends + PredType(..), -- to friends - Kind, PredType, ThetaType, -- Synonyms + Kind, ThetaType, -- Synonyms TyVarSubst, superKind, superBoxity, -- KX and BX respectively @@ -19,25 +20,32 @@ module TypeRep ( mkArrowKind, mkArrowKinds, -- :: KX -> KX -> KX funTyCon +#ifdef DEBUG + , crudePprType +#endif ) where #include "HsVersions.h" +import {-# SOURCE #-} DataCon( DataCon ) + -- friends: -import Var ( TyVar ) +import Var ( Id, TyVar, tyVarKind ) import VarEnv ( TyVarEnv ) import VarSet ( TyVarSet ) -import Name ( Name ) +import Name ( Name, mkWiredInName, mkInternalName ) +import OccName ( mkOccFS, mkKindOccFS, tcName ) import BasicTypes ( IPName ) -import TyCon ( TyCon, KindCon, mkFunTyCon, mkKindCon, mkSuperKindCon ) +import TyCon ( TyCon, KindCon, mkFunTyCon, mkKindCon, mkSuperKindCon, isNewTyCon ) import Class ( Class ) -import Binary -- others -import PrelNames ( superKindName, superBoxityName, liftedConName, - unliftedConName, typeConName, openKindConName, - funTyConName +import PrelNames ( gHC_PRIM, kindConKey, boxityConKey, liftedConKey, + unliftedConKey, typeConKey, anyBoxConKey, + funTyConKey ) +import SrcLoc ( noSrcLoc ) +import Outputable \end{code} %************************************************************************ @@ -109,22 +117,28 @@ Here the 'implicit expansion' we get from treating P and Q as transparent would give rise to infinite types, which in turn makes eqType diverge. Similarly splitForAllTys and splitFunTys can get into a loop. -Solution: for recursive newtypes use a coerce, and treat the newtype -and its representation as distinct right through the compiler. That's -what you get if you use recursive newtypes. (They are rare, so who -cares if they are a tiny bit less efficient.) +Solution: + +* Newtypes are always represented using NewTcApp, never as TyConApp. -So: non-recursive newtypes are represented using a SourceTy (see below) - recursive newtypes are represented using a TyConApp +* For non-recursive newtypes, P, treat P just like a type synonym after + type-checking is done; i.e. it's opaque during type checking (functions + from TcType) but transparent afterwards (functions from Type). + "Treat P as a type synonym" means "all functions expand NewTcApps + on the fly". -The TyCon still says "I'm a newtype", but we do not represent the -newtype application as a SourceType; instead as a TyConApp. + Applications of the data constructor P simply vanish: + P x = x + +* For recursive newtypes Q, treat the Q and its representation as + distinct right through the compiler. Applications of the data consructor + use a coerce: + Q = \(x::Q->Q). coerce Q x + They are rare, so who cares if they are a tiny bit less efficient. -NOTE: currently [March 02] we regard a newtype as 'recursive' if it's in a -mutually recursive group. That's a bit conservative: only if there's a loop -consisting only of newtypes do we need consider it as recursive. But it's -not so easy to discover that, and the situation isn't that common. +The typechecker (TcTyDecls) identifies enough type construtors as 'recursive' +to cut all loops. The other members of the loop may be marked 'non-recursive'. %************************************************************************ @@ -152,6 +166,19 @@ data Type -- synonyms have their own constructors, below. [Type] -- Might not be saturated. + | NewTcApp -- Application of a NewType TyCon. All newtype applications + TyCon -- show up like this until they are fed through newTypeRep, + -- which returns + -- * an ordinary TyConApp for non-saturated, + -- or recursive newtypes + -- + -- * the representation type of the newtype for satuarted, + -- non-recursive ones + -- [But the result of a call to newTypeRep is always consumed + -- immediately; it never lives on in another type. So in any + -- type, newtypes are always represented with NewTcApp.] + [Type] -- Might not be saturated. + | FunTy -- Special case of TyConApp: TyConApp FunTyCon [t1,t2] Type Type @@ -160,8 +187,8 @@ data Type TyVar Type - | SourceTy -- A high level source type - SourceType -- ...can be expanded to a representation type... + | PredTy -- A high level source type + PredType -- ...can be expanded to a representation type... | NoteTy -- A type with a note attached TyNote @@ -173,24 +200,20 @@ data TyNote | SynNote Type -- Used for type synonyms -- The Type is always a TyConApp, and is the un-expanded form. -- The type to which the note is attached is the expanded form. - \end{code} ------------------------------------- Source types A type of the form - SourceTy sty -represents a value whose type is the Haskell source type sty. + PredTy p +represents a value whose type is the Haskell predicate p, +where a predicate is what occurs before the '=>' in a Haskell type. It can be expanded into its representation, but: * The type checker must treat it as opaque * The rest of the compiler treats it as transparent -There are two main uses - a) Haskell predicates - b) newtypes - Consider these examples: f :: (Eq a) => a -> Int g :: (?x :: Int -> Int) => a -> Int @@ -200,13 +223,10 @@ Here the "Eq a" and "?x :: Int -> Int" and "r\l" are all called *predicates* Predicates are represented inside GHC by PredType: \begin{code} -data SourceType +data PredType = ClassP Class [Type] -- Class predicate | IParam (IPName Name) Type -- Implicit parameter - | NType TyCon [Type] -- A *saturated*, *non-recursive* newtype application - -- [See notes at top about newtypes] -type PredType = SourceType -- A subtype for predicates type ThetaType = [PredType] \end{code} @@ -274,6 +294,20 @@ Define KX, the type of a kind BX, the type of a boxity \begin{code} +superKindName = kindQual FSLIT("KX") kindConKey +superBoxityName = kindQual FSLIT("BX") boxityConKey +liftedConName = kindQual FSLIT("*") liftedConKey +unliftedConName = kindQual FSLIT("#") unliftedConKey +openKindConName = kindQual FSLIT("?") anyBoxConKey +typeConName = kindQual FSLIT("Type") typeConKey + +kindQual str uq = mkInternalName uq (mkKindOccFS tcName str) noSrcLoc + -- Kinds are not z-encoded in interface file, hence mkKindOccFS + -- And they don't come from any particular module; indeed we always + -- want to print them unqualified. Hence the InternalName. +\end{code} + +\begin{code} superKind :: SuperKind -- KX, the type of all kinds superKind = TyConApp (mkSuperKindCon superKindName) [] @@ -320,28 +354,25 @@ mkArrowKinds :: [Kind] -> Kind -> Kind mkArrowKinds arg_kinds result_kind = foldr mkArrowKind result_kind arg_kinds \end{code} ------------------------------------------------------------------------------ -Binary kinds for interface files + +%************************************************************************ +%* * + TyThing +%* * +%************************************************************************ + +Despite the fact that DataCon has to be imported via a hi-boot route, +this module seems the right place for TyThing, because it's needed for +funTyCon and all the types in TysPrim. \begin{code} -instance Binary Kind where - put_ bh k@(TyConApp tc []) - | tc == openKindCon = putByte bh 0 - put_ bh k@(TyConApp tc [TyConApp bc _]) - | tc == typeCon && bc == liftedBoxityCon = putByte bh 2 - | tc == typeCon && bc == unliftedBoxityCon = putByte bh 3 - put_ bh (FunTy f a) = do putByte bh 4; put_ bh f; put_ bh a - put_ bh _ = error "Binary.put(Kind): strange-looking Kind" - - get bh = do - b <- getByte bh - case b of - 0 -> return openTypeKind - 2 -> return liftedTypeKind - 3 -> return unliftedTypeKind - _ -> do f <- get bh; a <- get bh; return (FunTy f a) +data TyThing = AnId Id + | ADataCon DataCon + | ATyCon TyCon + | AClass Class \end{code} + %************************************************************************ %* * \subsection{Wired-in type constructors @@ -359,6 +390,45 @@ funTyCon = mkFunTyCon funTyConName (mkArrowKinds [liftedTypeKind, liftedTypeKind -- expected/actual stuff in the unifier does not go contra-variant, whereas -- the kind sub-typing does. Sigh. It really only matters if you use (->) in -- a prefix way, thus: (->) Int# Int#. And this is unusual. + +funTyConName = mkWiredInName gHC_PRIM + (mkOccFS tcName FSLIT("(->)")) + funTyConKey + Nothing -- No parent object + (ATyCon funTyCon) -- Relevant TyCon \end{code} + +%************************************************************************ +%* * + Crude printing + For debug purposes, we may want to print a type directly +%* * +%************************************************************************ + +\begin{code} +#ifdef DEBUG +crudePprType :: Type -> SDoc +crudePprType (TyVarTy tv) = ppr tv +crudePprType (AppTy t1 t2) = crudePprType t1 <+> (parens (crudePprType t2)) +crudePprType (FunTy t1 t2) = crudePprType t1 <+> (parens (crudePprType t2)) +crudePprType (TyConApp tc tys) = ppr_tc_app (ppr tc <> pp_nt tc) tys +crudePprType (NewTcApp tc tys) = ptext SLIT("<nt>") <+> ppr_tc_app (ppr tc <> pp_nt tc) tys +crudePprType (ForAllTy tv ty) = sep [ptext SLIT("forall") <+> + parens (ppr tv <+> crudePprType (tyVarKind tv)) <> dot, + crudePprType ty] +crudePprType (PredTy st) = braces (crudePprPredTy st) +crudePprType (NoteTy (SynNote ty1) ty2) = crudePprType ty1 +crudePprType (NoteTy other ty) = crudePprType ty + +crudePprPredTy (ClassP cls tys) = ppr_tc_app (ppr cls) tys +crudePprPredTy (IParam ip ty) = ppr ip <> dcolon <> crudePprType ty + +ppr_tc_app :: SDoc -> [Type] -> SDoc +ppr_tc_app tc tys = tc <+> sep (map (parens . crudePprType) tys) + +pp_nt tc | isNewTyCon tc = ptext SLIT("(nt)") + | otherwise = empty +#endif +\end{code}
\ No newline at end of file diff --git a/ghc/compiler/types/Variance.lhs b/ghc/compiler/types/Variance.lhs deleted file mode 100644 index 9b6ad508aa..0000000000 --- a/ghc/compiler/types/Variance.lhs +++ /dev/null @@ -1,190 +0,0 @@ -% -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1999 -% -\section[Variance]{Variance in @Type@ and @TyCon@} - -\begin{code} -module Variance( - calcTyConArgVrcs, - tyVarVrc - ) where - -#include "HsVersions.h" - -import TypeRep ( Type(..), TyNote(..) ) -- friend -import TyCon ( TyCon, ArgVrcs, tyConArity, tyConDataCons_maybe, tyConDataCons, tyConTyVars, - tyConArgVrcs_maybe, getSynTyConDefn, isSynTyCon, isAlgTyCon ) -import DataCon ( dataConRepArgTys ) - -import FiniteMap -import Var ( TyVar ) -import VarSet -import Maybes ( expectJust ) -import Maybe ( isNothing ) -import Outputable -\end{code} - - -Computing the tyConArgVrcs info -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -@tyConArgVrcs@ gives a list of (occPos,occNeg) flags, one for each -tyvar. For @AlgTyCon@s and @SynTyCon@s, this info must be precomputed -separately. Note that this is information about occurrences of type -variables, not usages of term variables. - -The function @calcTyConArgVrcs@ must be passed a list of *algebraic or -syntycons only* such that all tycons referred to (by mutual recursion) -appear in the list. The fixpointing will be done on this set of -tycons as a whole. It returns a list of @tyconVrcInfo@ data, ready to -be (knot-tyingly?) stuck back into the appropriate fields. - -\begin{code} -calcTyConArgVrcs :: [TyCon] -> FiniteMap TyCon ArgVrcs - -calcTyConArgVrcs tycons - = tcaoFix initial_oi - where - - initial_oi :: FiniteMap TyCon ArgVrcs - initial_oi = foldl (\fm tc -> addToFM fm tc (initial tc)) emptyFM tycons - initial tc = if isAlgTyCon tc && isNothing (tyConDataCons_maybe tc) then - -- make pessimistic assumption (and warn) - abstractVrcs tc - else - replicate (tyConArity tc) (False,False) - - tcaoFix :: FiniteMap TyCon ArgVrcs -- initial ArgVrcs per tycon - -> FiniteMap TyCon ArgVrcs -- fixpointed ArgVrcs per tycon - - tcaoFix oi = let (changed,oi') = foldFM (\ tc pms - (changed,oi') - -> let pms' = tcaoIter oi' tc -- seq not simult - in (changed || (pms /= pms'), - addToFM oi' tc pms')) - (False,oi) -- seq not simult for faster fixpting - oi - in if changed - then tcaoFix oi' - else oi' - - tcaoIter :: FiniteMap TyCon ArgVrcs -- reference ArgVrcs (initial) - -> TyCon -- tycon to update - -> ArgVrcs -- new ArgVrcs for tycon - - tcaoIter oi tc | isAlgTyCon tc - = if null data_cons then - -- Abstract types get uninformative variances - abstractVrcs tc - else - map (\v -> anyVrc (\ty -> vrcInTy myfao v ty) argtys) - vs - where - data_cons = tyConDataCons tc - vs = tyConTyVars tc - argtys = concatMap dataConRepArgTys data_cons - myfao tc = lookupWithDefaultFM oi (expectJust "tcaoIter(Alg)" $ - tyConArgVrcs_maybe tc) - tc - -- we use the already-computed result for tycons not in this SCC - - tcaoIter oi tc | isSynTyCon tc - = let (tyvs,ty) = getSynTyConDefn tc - myfao tc = lookupWithDefaultFM oi (expectJust "tcaoIter(Syn)" $ - tyConArgVrcs_maybe tc) - tc - -- we use the already-computed result for tycons not in this SCC - in map (\v -> vrcInTy myfao v ty) tyvs - - -abstractVrcs :: TyCon -> ArgVrcs -abstractVrcs tc = -#ifdef DEBUG - pprTrace "Vrc: abstract tycon:" (ppr tc) $ -#endif - replicate (tyConArity tc) (True,True) -\end{code} - - -Variance of tyvars in a type -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -A general variance-check function. We pass a function for determining -the @ArgVrc@s of a tycon; when fixpointing this refers to the current -value; otherwise this should be looked up from the tycon's own -tyConArgVrcs. - -\begin{code} -vrcInTy :: (TyCon -> ArgVrcs) -- function to get argVrcs of a tycon (break out of recursion) - -> TyVar -- tyvar to check Vrcs of - -> Type -- type to check for occ in - -> (Bool,Bool) -- (occurs positively, occurs negatively) - -vrcInTy fao v (NoteTy (SynNote _) ty) = vrcInTy fao v ty - -- SynTyCon doesn't neccessarily have vrcInfo at this point, - -- so don't try and use it - -vrcInTy fao v (NoteTy (FTVNote ftv) ty) = if elemVarSet v ftv - then vrcInTy fao v ty - else (False,False) - -- note that ftv cannot be calculated as occPos||occNeg, - -- since if a tyvar occurs only as unused tyconarg, - -- occPos==occNeg==False, but ftv=True - -vrcInTy fao v (TyVarTy v') = if v==v' - then (True,False) - else (False,False) - -vrcInTy fao v (AppTy ty1 ty2) = if vrcInTy fao v ty2 /= (False,False) - then (True,True) - else vrcInTy fao v ty1 - -- ty1 is probably unknown (or it would have been beta-reduced); - -- hence if v occurs in ty2 at all then it could occur with - -- either variance. Otherwise it occurs as it does in ty1. - -vrcInTy fao v (FunTy ty1 ty2) = negVrc (vrcInTy fao v ty1) - `orVrc` - vrcInTy fao v ty2 - -vrcInTy fao v (ForAllTy v' ty) = if v==v' - then (False,False) - else vrcInTy fao v ty - -vrcInTy fao v (TyConApp tc tys) = let pms1 = map (vrcInTy fao v) tys - pms2 = fao tc - in orVrcs (zipWith timesVrc pms1 pms2) -\end{code} - - -External entry point: assumes tyconargvrcs already computed. - -\begin{code} -tyVarVrc :: TyVar -- tyvar to check Vrc of - -> Type -- type to check for occ in - -> (Bool,Bool) -- (occurs positively, occurs negatively) - -tyVarVrc = vrcInTy (expectJust "tyVarVrcs" . tyConArgVrcs_maybe) -\end{code} - - -Variance algebra -~~~~~~~~~~~~~~~~ - -\begin{code} -orVrc :: (Bool,Bool) -> (Bool,Bool) -> (Bool,Bool) -orVrc (p1,m1) (p2,m2) = (p1||p2,m1||m2) - -orVrcs :: [(Bool,Bool)] -> (Bool,Bool) -orVrcs = foldl orVrc (False,False) - -negVrc :: (Bool,Bool) -> (Bool,Bool) -negVrc (p1,m1) = (m1,p1) - -anyVrc :: (a -> (Bool,Bool)) -> [a] -> (Bool,Bool) -anyVrc p as = foldl (\ pm a -> pm `orVrc` p a) - (False,False) as - -timesVrc :: (Bool,Bool) -> (Bool,Bool) -> (Bool,Bool) -timesVrc (p1,m1) (p2,m2) = (p1 && p2 || m1 && m2, - p1 && m2 || m1 && p2) -\end{code} diff --git a/ghc/compiler/utils/Binary.hs b/ghc/compiler/utils/Binary.hs index 690fb56614..90c7e53a7e 100644 --- a/ghc/compiler/utils/Binary.hs +++ b/ghc/compiler/utils/Binary.hs @@ -19,8 +19,6 @@ module Binary openBinMem, -- closeBin, - getUserData, - seekBin, tellBin, castBin, @@ -44,7 +42,7 @@ module Binary putByteArray, getBinFileWithDict, -- :: Binary a => FilePath -> IO a - putBinFileWithDict, -- :: Binary a => FilePath -> Module -> a -> IO () + putBinFileWithDict, -- :: Binary a => FilePath -> ModuleName -> a -> IO () ) where @@ -53,7 +51,6 @@ module Binary -- The *host* architecture version: #include "MachDeps.h" -import {-# SOURCE #-} Module import FastString import Unique import Panic @@ -143,9 +140,13 @@ eofErrorType = EOF type BinArray = IOUArray Int Word8 #endif +--------------------------------------------------------------- +-- BinHandle +--------------------------------------------------------------- + data BinHandle = BinMem { -- binary data stored in an unboxed array - state :: BinHandleState, -- sigh, need parameterized modules :-) + bh_usr :: UserData, -- sigh, need parameterized modules :-) off_r :: !FastMutInt, -- the current offset sz_r :: !FastMutInt, -- size of the array (cached) arr_r :: !(IORef BinArray) -- the array (bounds: (0,size-1)) @@ -154,7 +155,7 @@ data BinHandle -- the binary data to a file. | BinIO { -- binary data stored in a file - state :: BinHandleState, + bh_usr :: UserData, off_r :: !FastMutInt, -- the current offset (cached) hdl :: !IO.Handle -- the file handle (must be seekable) } @@ -162,12 +163,27 @@ data BinHandle -- to call repeatedly. If anyone else is modifying this Handle -- at the same time, we'll be screwed. +getUserData :: BinHandle -> UserData +getUserData bh = bh_usr bh + +setUserData :: BinHandle -> UserData -> BinHandle +setUserData bh us = bh { bh_usr = us } + + +--------------------------------------------------------------- +-- Bin +--------------------------------------------------------------- + newtype Bin a = BinPtr Int deriving (Eq, Ord, Show, Bounded) castBin :: Bin a -> Bin b castBin (BinPtr i) = BinPtr i +--------------------------------------------------------------- +-- class Binary +--------------------------------------------------------------- + class Binary a where put_ :: BinHandle -> a -> IO () put :: BinHandle -> a -> IO (Bin a) @@ -186,17 +202,16 @@ getAt :: Binary a => BinHandle -> Bin a -> IO a getAt bh p = do seekBin bh p; get bh openBinIO_ :: IO.Handle -> IO BinHandle -openBinIO_ h = openBinIO h noBinHandleUserData +openBinIO_ h = openBinIO h -openBinIO :: IO.Handle -> Module -> IO BinHandle -openBinIO h mod = do +openBinIO :: IO.Handle -> IO BinHandle +openBinIO h = do r <- newFastMutInt writeFastMutInt r 0 - state <- newWriteState mod - return (BinIO state r h) + return (BinIO noUserData r h) -openBinMem :: Int -> Module -> IO BinHandle -openBinMem size mod +openBinMem :: Int -> IO BinHandle +openBinMem size | size <= 0 = error "Data.Binary.openBinMem: size must be >= 0" | otherwise = do arr <- newArray_ (0,size-1) @@ -205,13 +220,7 @@ openBinMem size mod writeFastMutInt ix_r 0 sz_r <- newFastMutInt writeFastMutInt sz_r size - state <- newWriteState mod - return (BinMem state ix_r sz_r arr_r) - -noBinHandleUserData = error "Binary.BinHandle: no user data" - -getUserData :: BinHandle -> BinHandleState -getUserData bh = state bh + return (BinMem noUserData ix_r sz_r arr_r) tellBin :: BinHandle -> IO (Bin a) tellBin (BinIO _ r _) = do ix <- readFastMutInt r; return (BinPtr ix) @@ -250,6 +259,7 @@ writeBinMem (BinMem _ ix_r sz_r arr_r) fn = do hClose h readBinMem :: FilePath -> IO BinHandle +-- Return a BinHandle with a totally undefined State readBinMem filename = do h <- openBinaryFile filename ReadMode filesize' <- hFileSize h @@ -264,7 +274,7 @@ readBinMem filename = do writeFastMutInt ix_r 0 sz_r <- newFastMutInt writeFastMutInt sz_r filesize - return (BinMem initReadState ix_r sz_r arr_r) + return (BinMem noUserData ix_r sz_r arr_r) -- expand the size of the array to include a specified offset expandBin :: BinHandle -> Int -> IO () @@ -596,66 +606,110 @@ lazyGet bh = do seekBin bh p -- skip over the object for now return a --- ----------------------------------------------------------------------------- --- BinHandleState - -type BinHandleState = - (Module, - IORef Int, - IORef (UniqFM (Int,FastString)), - Array Int FastString) - -initReadState :: BinHandleState -initReadState = (undef, undef, undef, undef) - -newWriteState :: Module -> IO BinHandleState -newWriteState m = do - j_r <- newIORef 0 - out_r <- newIORef emptyUFM - return (m,j_r,out_r,undef) - -undef = error "Binary.BinHandleState" +-- -------------------------------------------------------------- +-- Main wrappers: getBinFileWithDict, putBinFileWithDict +-- +-- This layer is built on top of the stuff above, +-- and should not know anything about BinHandles +-- -------------------------------------------------------------- --- ----------------------------------------------------------------------------- --- FastString binary interface +initBinMemSize = (1024*1024) :: Int +binaryInterfaceMagic = 0x1face :: Word32 getBinFileWithDict :: Binary a => FilePath -> IO a getBinFileWithDict file_path = do bh <- Binary.readBinMem file_path + + -- Read the magic number to check that this really is a GHC .hi file + -- (This magic number does not change when we change + -- GHC interface file format) magic <- get bh when (magic /= binaryInterfaceMagic) $ throwDyn (ProgramError ( "magic number mismatch: old/corrupt interface file?")) - dict_p <- Binary.get bh -- get the dictionary ptr - data_p <- tellBin bh + + -- Read the dictionary + -- The next word in the file is a pointer to where the dictionary is + -- (probably at the end of the file) + dict_p <- Binary.get bh -- Get the dictionary ptr + data_p <- tellBin bh -- Remember where we are now seekBin bh dict_p dict <- getDictionary bh - seekBin bh data_p - let (mod, j_r, out_r, _) = state bh - get bh{ state = (mod,j_r,out_r,dict) } - -initBinMemSize = (1024*1024) :: Int + seekBin bh data_p -- Back to where we were before -binaryInterfaceMagic = 0x1face :: Word32 + -- Initialise the user-data field of bh + let bh' = setUserData bh (initReadState dict) + + -- At last, get the thing + get bh' -putBinFileWithDict :: Binary a => FilePath -> Module -> a -> IO () -putBinFileWithDict file_path mod a = do - bh <- openBinMem initBinMemSize mod +putBinFileWithDict :: Binary a => FilePath -> a -> IO () +putBinFileWithDict file_path the_thing = do + bh <- openBinMem initBinMemSize put_ bh binaryInterfaceMagic - p <- tellBin bh - put_ bh p -- placeholder for ptr to dictionary - put_ bh a - let (_, j_r, fm_r, _) = state bh - j <- readIORef j_r - fm <- readIORef fm_r - dict_p <- tellBin bh - putAt bh p dict_p -- fill in the placeholder - seekBin bh dict_p -- seek back to the end of the file + + -- Remember where the dictionary pointer will go + dict_p_p <- tellBin bh + put_ bh dict_p_p -- Placeholder for ptr to dictionary + + -- Make some intial state + usr_state <- newWriteState + + -- Put the main thing, + put_ (setUserData bh usr_state) the_thing + + -- Get the final-state + j <- readIORef (ud_next usr_state) + fm <- readIORef (ud_map usr_state) + dict_p <- tellBin bh -- This is where the dictionary will start + + -- Write the dictionary pointer at the fornt of the file + putAt bh dict_p_p dict_p -- Fill in the placeholder + seekBin bh dict_p -- Seek back to the end of the file + + -- Write the dictionary itself putDictionary bh j (constructDictionary j fm) + + -- And send the result to the file writeBinMem bh file_path -type Dictionary = Array Int FastString - -- should be 0-indexed +-- ----------------------------------------------------------------------------- +-- UserData +-- ----------------------------------------------------------------------------- + +data UserData = + UserData { -- This field is used only when reading + ud_dict :: Dictionary, + + -- The next two fields are only used when writing + ud_next :: IORef Int, -- The next index to use + ud_map :: IORef (UniqFM (Int,FastString)) + } + +noUserData = error "Binary.UserData: no user data" + +initReadState :: Dictionary -> UserData +initReadState dict = UserData{ ud_dict = dict, + ud_next = undef "next", + ud_map = undef "map" } + +newWriteState :: IO UserData +newWriteState = do + j_r <- newIORef 0 + out_r <- newIORef emptyUFM + return (UserData { ud_dict = panic "dict", + ud_next = j_r, + ud_map = out_r }) + + +undef s = panic ("Binary.UserData: no " ++ s) + +--------------------------------------------------------- +-- The Dictionary +--------------------------------------------------------- + +type Dictionary = Array Int FastString -- The dictionary + -- Should be 0-indexed putDictionary :: BinHandle -> Int -> Dictionary -> IO () putDictionary bh sz dict = do @@ -671,6 +725,10 @@ getDictionary bh = do constructDictionary :: Int -> UniqFM (Int,FastString) -> Dictionary constructDictionary j fm = array (0,j-1) (eltsUFM fm) +--------------------------------------------------------- +-- Reading and writing FastStrings +--------------------------------------------------------- + putFS bh (FastString id l ba) = do put_ bh (I# l) putByteArray bh ba l @@ -693,7 +751,8 @@ getFS bh = do instance Binary FastString where put_ bh f@(FastString id l ba) = - case getUserData bh of { (_, j_r, out_r, dict) -> do + case getUserData bh of { + UserData { ud_next = j_r, ud_map = out_r, ud_dict = dict} -> do out <- readIORef out_r let uniq = getUnique f case lookupUFM out uniq of @@ -708,4 +767,4 @@ instance Binary FastString where get bh = do j <- get bh - case getUserData bh of (_, _, _, arr) -> return $! (arr ! j) + return $! (ud_dict (getUserData bh) ! j) diff --git a/ghc/compiler/utils/Digraph.lhs b/ghc/compiler/utils/Digraph.lhs index d8f6220658..cd0e17d50a 100644 --- a/ghc/compiler/utils/Digraph.lhs +++ b/ghc/compiler/utils/Digraph.lhs @@ -32,8 +32,6 @@ module Digraph( ------------------------------------------------------------------------------ -#define ARR_ELT (COMMA) - import Util ( sortLt ) -- Extensions @@ -80,7 +78,8 @@ stronglyConnComp => [(node, key, [key])] -- The graph; its ok for the -- out-list to contain keys which arent -- a vertex key, they are ignored - -> [SCC node] + -> [SCC node] -- Returned in topologically sorted order + -- Later components depend on earlier ones, but not vice versa stronglyConnComp edges = map get_node (stronglyConnCompR edges) @@ -307,9 +306,6 @@ preorder (Node a ts) = a : preorderF ts preorderF :: Forest a -> [a] preorderF ts = concat (map preorder ts) -preOrd :: Graph -> [Vertex] -preOrd = preorderF . dff - tabulate :: Bounds -> [Vertex] -> Table Int tabulate bnds vs = array bnds (zipWith (,) vs [1..]) @@ -363,12 +359,6 @@ scc g = dfs g (reverse (postOrd (transposeG g))) ------------------------------------------------------------ \begin{code} -tree :: Bounds -> Forest Vertex -> Graph -tree bnds ts = buildG bnds (concat (map flat ts)) - where - flat (Node v rs) = [ (v, w) | Node w us <- ts ] ++ - concat (map flat ts) - back :: Graph -> Table Int -> Graph back g post = mapT select g where select v ws = [ w | w <- ws, post!v < post!w ] diff --git a/ghc/compiler/utils/FastString.lhs b/ghc/compiler/utils/FastString.lhs index 61750aabdb..d46b775996 100644 --- a/ghc/compiler/utils/FastString.lhs +++ b/ghc/compiler/utils/FastString.lhs @@ -106,6 +106,7 @@ instance Eq FastString where a /= b = case cmpFS a b of { LT -> True; EQ -> False; GT -> True } instance Ord FastString where + -- Compares lexicographically, not by unique a <= b = case cmpFS a b of { LT -> True; EQ -> True; GT -> False } a < b = case cmpFS a b of { LT -> True; EQ -> False; GT -> False } a >= b = case cmpFS a b of { LT -> False; EQ -> True; GT -> True } diff --git a/ghc/compiler/utils/Maybes.lhs b/ghc/compiler/utils/Maybes.lhs index 353c3b5a5c..961da188e8 100644 --- a/ghc/compiler/utils/Maybes.lhs +++ b/ghc/compiler/utils/Maybes.lhs @@ -5,16 +5,18 @@ \begin{code} module Maybes ( + module Maybe, -- Re-export all of Maybe + MaybeErr(..), orElse, - mapMaybe, + mapCatMaybes, allMaybes, firstJust, expectJust, maybeToBool, - thenMaybe, seqMaybe, returnMaybe, failMaybe, catMaybes, + thenMaybe, seqMaybe, returnMaybe, failMaybe, thenMaB, returnMaB, failMaB @@ -22,7 +24,7 @@ module Maybes ( #include "HsVersions.h" -import Maybe( catMaybes, mapMaybe ) +import Maybe infixr 4 `orElse` @@ -66,20 +68,20 @@ firstJust (Nothing : ms) = firstJust ms \end{code} \begin{code} -findJust :: (a -> Maybe b) -> [a] -> Maybe b -findJust f [] = Nothing -findJust f (a:as) = case f a of - Nothing -> findJust f as - b -> b -\end{code} - -\begin{code} expectJust :: String -> Maybe a -> a {-# INLINE expectJust #-} expectJust err (Just x) = x expectJust err Nothing = error ("expectJust " ++ err) \end{code} +\begin{code} +mapCatMaybes :: (a -> Maybe b) -> [a] -> [b] +mapCatMaybes f [] = [] +mapCatMaybes f (x:xs) = case f x of + Just y -> y : mapCatMaybes f xs + Nothing -> mapCatMaybes f xs +\end{code} + The Maybe monad ~~~~~~~~~~~~~~~ \begin{code} diff --git a/ghc/compiler/utils/Outputable.lhs b/ghc/compiler/utils/Outputable.lhs index 2ef0adffe3..dcfe8c2dbc 100644 --- a/ghc/compiler/utils/Outputable.lhs +++ b/ghc/compiler/utils/Outputable.lhs @@ -26,7 +26,7 @@ module Outputable ( text, char, ftext, ptext, int, integer, float, double, rational, parens, brackets, braces, quotes, doubleQuotes, angleBrackets, - semi, comma, colon, dcolon, space, equals, dot, + semi, comma, colon, dcolon, space, equals, dot, arrow, lparen, rparen, lbrack, rbrack, lbrace, rbrace, underscore, (<>), (<+>), hcat, hsep, ($$), ($+$), vcat, @@ -82,8 +82,6 @@ data PprStyle -- must be very close to Haskell -- syntax, etc. - | PprInterface PrintUnqualified -- Interface generation - | PprCode CodeStyle -- Print code; either C or assembler | PprDebug -- Standard debugging output @@ -156,7 +154,6 @@ getPprStyle df sty = df sty sty \begin{code} unqualStyle :: PprStyle -> Name -> Bool unqualStyle (PprUser unqual _) n = unqual n -unqualStyle (PprInterface unqual) n = unqual n unqualStyle other n = False codeStyle :: PprStyle -> Bool @@ -201,7 +198,7 @@ printDump doc = do better_doc = doc $$ text "" -- We used to always print in debug style, but I want -- to try the effect of a more user-ish style (unless you - -- say -dppr-debug + -- say -dppr-debug) printForUser :: Handle -> PrintUnqualified -> SDoc -> IO () printForUser handle unqual doc @@ -282,6 +279,7 @@ rbrack sty = Pretty.rbrack lbrace sty = Pretty.lbrace rbrace sty = Pretty.rbrace dcolon sty = Pretty.ptext SLIT("::") +arrow sty = Pretty.ptext SLIT("->") underscore = char '_' dot = char '.' diff --git a/ghc/compiler/utils/Pretty.lhs b/ghc/compiler/utils/Pretty.lhs index ab9864b68b..a3cb5325cf 100644 --- a/ghc/compiler/utils/Pretty.lhs +++ b/ghc/compiler/utils/Pretty.lhs @@ -1013,7 +1013,7 @@ spaces n = ' ' : spaces (n MINUS ILIT(1)) \end{code} \begin{code} -pprCols = (100 :: Int) -- could make configurable +pprCols = (120 :: Int) -- could make configurable printDoc :: Mode -> Handle -> Doc -> IO () printDoc mode hdl doc diff --git a/ghc/compiler/utils/Util.lhs b/ghc/compiler/utils/Util.lhs index 28880a2446..bb22d4e9be 100644 --- a/ghc/compiler/utils/Util.lhs +++ b/ghc/compiler/utils/Util.lhs @@ -527,13 +527,13 @@ balancedFold' :: (a -> a -> a) -> [a] -> [a] balancedFold' f (x:y:xs) = f x y : balancedFold' f xs balancedFold' f xs = xs -generalMergeSort p [] = [] -generalMergeSort p xs = (balancedFold (generalMerge p) . map (: [])) xs - generalNaturalMergeSort p [] = [] generalNaturalMergeSort p xs = (balancedFold (generalMerge p) . group p) xs #if NOT_USED +generalMergeSort p [] = [] +generalMergeSort p xs = (balancedFold (generalMerge p) . map (: [])) xs + mergeSort, naturalMergeSort :: Ord a => [a] -> [a] mergeSort = generalMergeSort (<=) @@ -772,11 +772,6 @@ applyToFst f (x,y) = (f x,y) applyToSnd :: (b -> d) -> (a,b) -> (a,d) applyToSnd f (x,y) = (x,f y) #endif - -foldPair :: (a->a->a,b->b->b) -> (a,b) -> [(a,b)] -> (a,b) -foldPair fg ab [] = ab -foldPair fg@(f,g) ab ((a,b):abs) = (f a u,g b v) - where (u,v) = foldPair fg ab abs \end{code} \begin{code} |