diff options
| author | simonpj <unknown> | 2000-05-25 12:41:22 +0000 |
|---|---|---|
| committer | simonpj <unknown> | 2000-05-25 12:41:22 +0000 |
| commit | 495ef8bd9ef30bffe50ea399b91e3ba09646b59a (patch) | |
| tree | b9ee4302d494d28a81879051d9d3e2a7693ec5e8 /ghc | |
| parent | b5c71bff716366ae888bf120776d3e163c86c60a (diff) | |
| download | haskell-495ef8bd9ef30bffe50ea399b91e3ba09646b59a.tar.gz | |
[project @ 2000-05-25 12:41:14 by simonpj]
~~~~~~~~~~~~
Apr/May 2000
~~~~~~~~~~~~
This is a pretty big commit! It adds stuff I've been working on
over the last month or so. DO NOT MERGE IT WITH 4.07!
Interface file formats have changed a little; you'll need
to make clean before remaking.
Simon PJ
Recompilation checking
~~~~~~~~~~~~~~~~~~~~~~
Substantial improvement in recompilation checking. The version management
is now entirely internal to GHC. ghc-iface.lprl is dead!
The trick is to generate the new interface file in two steps:
- first convert Types etc to HsTypes etc, and thereby
build a new ParsedIface
- then compare against the parsed (but not renamed) version of the old
interface file
Doing this meant adding code to convert *to* HsSyn things, and to
compare HsSyn things for equality. That is the main tedious bit.
Another improvement is that we now track version info for
fixities and rules, which was missing before.
Interface file reading
~~~~~~~~~~~~~~~~~~~~~~
Make interface files reading more robust.
* If the old interface file is unreadable, don't fail. [bug fix]
* If the old interface file mentions interfaces
that are unreadable, don't fail. [bug fix]
* When we can't find the interface file,
print the directories we are looking in. [feature]
Type signatures
~~~~~~~~~~~~~~~
* New flag -ddump-types to print type signatures
Type pruning
~~~~~~~~~~~~
When importing
data T = T1 A | T2 B | T3 C
it seems excessive to import the types A, B, C as well, unless
the constructors T1, T2 etc are used. A,B,C might be more types,
and importing them may mean reading more interfaces, and so on.
So the idea is that the renamer will just import the decl
data T
unless one of the constructors is used. This turns out to be quite
easy to implement. The downside is that we must make sure the
constructors are always available if they are really needed, so
I regard this as an experimental feature.
Elimininate ThinAir names
~~~~~~~~~~~~~~~~~~~~~~~~~
Eliminate ThinAir.lhs and all its works. It was always a hack, and now
the desugarer carries around an environment I think we can nuke ThinAir
altogether.
As part of this, I had to move all the Prelude RdrName defns from PrelInfo
to PrelMods --- so I renamed PrelMods as PrelNames.
I also had to move the builtinRules so that they are injected by the renamer
(rather than appearing out of the blue in SimplCore). This is if anything simpler.
Miscellaneous
~~~~~~~~~~~~~
* Tidy up the data types involved in Rules
* Eliminate RnEnv.better_provenance; use Name.hasBetterProv instead
* Add Unique.hasKey :: Uniquable a => a -> Unique -> Bool
It's useful in a lot of places
* Fix a bug in interface file parsing for __U[!]
Diffstat (limited to 'ghc')
122 files changed, 4269 insertions, 3968 deletions
diff --git a/ghc/compiler/DEPEND-NOTES b/ghc/compiler/DEPEND-NOTES index 3e67308be1..8f63938dcc 100644 --- a/ghc/compiler/DEPEND-NOTES +++ b/ghc/compiler/DEPEND-NOTES @@ -32,14 +32,14 @@ then then CoreSyn then - IdInfo (loop CoreSyn.CoreRules etc, loop CoreUnfold.Unfolding) + IdInfo (CoreSyn.Unfolding, CoreSyn.CoreRules) then Id (lots from IdInfo) then CoreFVs, PprCore then CoreUtils (PprCore.pprCoreExpr, CoreFVs.exprFreeVars, - loop CoreUnfold.isEvaldUnfolding CoreUnfold.maybeUnfoldingTemplate) + CoreSyn.isEvaldUnfolding CoreSyn.maybeUnfoldingTemplate) then OccurAnal (CoreUtils.exprIsTrivial) then diff --git a/ghc/compiler/basicTypes/BasicTypes.lhs b/ghc/compiler/basicTypes/BasicTypes.lhs index 5ddc45204a..14c9893bef 100644 --- a/ghc/compiler/basicTypes/BasicTypes.lhs +++ b/ghc/compiler/basicTypes/BasicTypes.lhs @@ -14,7 +14,7 @@ types that \begin{code} module BasicTypes( - Version, + Version, bumpVersion, initialVersion, bogusVersion, Arity, @@ -29,7 +29,10 @@ module BasicTypes( TopLevelFlag(..), isTopLevel, isNotTopLevel, + Boxity(..), isBoxed, tupleParens, + OccInfo(..), seqOccInfo, isFragileOccInfo, isLoopBreaker, + InsideLam, insideLam, notInsideLam, OneBranch, oneBranch, notOneBranch @@ -75,6 +78,15 @@ type Arity = Int \begin{code} type Version = Int + +bogusVersion :: Version -- Shouldn't look at these +bogusVersion = error "bogusVersion" + +bumpVersion :: Version -> Version +bumpVersion v = v+1 + +initialVersion :: Version +initialVersion = 1 \end{code} @@ -146,6 +158,28 @@ isTopLevel NotTopLevel = False %************************************************************************ %* * +\subsection[Top-level/local]{Top-level/not-top level flag} +%* * +%************************************************************************ + +\begin{code} +data Boxity + = Boxed + | Unboxed + deriving( Eq ) + +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} + + +%************************************************************************ +%* * \subsection[Recursive/Non-Recursive]{Recursive/Non-Recursive flag} %* * %************************************************************************ diff --git a/ghc/compiler/basicTypes/DataCon.lhs b/ghc/compiler/basicTypes/DataCon.lhs index a9aac4c7ed..be1cf56ac9 100644 --- a/ghc/compiler/basicTypes/DataCon.lhs +++ b/ghc/compiler/basicTypes/DataCon.lhs @@ -32,9 +32,9 @@ import TysPrim import Type ( Type, ThetaType, TauType, ClassContext, mkForAllTys, mkFunTys, mkTyConApp, mkTyVarTys, mkDictTys, - splitAlgTyConApp_maybe, classesToPreds + splitTyConApp_maybe, classesToPreds ) -import TyCon ( TyCon, tyConDataCons, isDataTyCon, isProductTyCon, +import TyCon ( TyCon, tyConDataCons, tyConDataConsIfAvailable, isDataTyCon, isProductTyCon, isTupleTyCon, isUnboxedTupleTyCon, isRecursiveTyCon ) import Class ( classTyCon ) import Name ( Name, NamedThing(..), nameUnique, isLocallyDefined ) @@ -120,7 +120,7 @@ data DataCon dcRepArgTys :: [Type], -- Final, representation argument types, after unboxing and flattening, -- and including existential dictionaries - dcTyCon :: TyCon, -- Result tycon + dcTyCon :: TyCon, -- Result tycon -- Now the strictness annotations and field labels of the constructor dcUserStricts :: [StrictnessMark], @@ -404,6 +404,7 @@ splitProductType_maybe [Type]) -- Its *representation* arg types -- Returns (Just ...) for any + -- concrete (i.e. constructors visible) -- single-constructor -- not existentially quantified -- type whether a data type or a new type @@ -413,10 +414,13 @@ splitProductType_maybe -- it through till someone finds it's important. splitProductType_maybe ty - = case splitAlgTyConApp_maybe ty of - Just (tycon,ty_args,[data_con]) - | isProductTyCon tycon -- Includes check for non-existential + = case splitTyConApp_maybe ty of + Just (tycon,ty_args) + | isProductTyCon tycon -- Includes check for non-existential, + -- and for constructors visible -> Just (tycon, ty_args, data_con, dataConArgTys data_con ty_args) + where + data_con = head (tyConDataConsIfAvailable tycon) other -> Nothing splitProductType str ty diff --git a/ghc/compiler/basicTypes/Demand.lhs b/ghc/compiler/basicTypes/Demand.lhs index 7f376fd326..546e3a2bbb 100644 --- a/ghc/compiler/basicTypes/Demand.lhs +++ b/ghc/compiler/basicTypes/Demand.lhs @@ -66,7 +66,8 @@ type MaybeAbsent = Bool -- True <=> not even used wwLazy = WwLazy False wwStrict = WwStrict wwUnpackData xs = WwUnpack DataType False xs -wwUnpackNew x = WwUnpack NewType False [x] +wwUnpackNew x = ASSERT( isStrict x) -- Invariant + WwUnpack NewType False [x] wwPrim = WwPrim wwEnum = WwEnum @@ -87,25 +88,20 @@ seqDemands (d:ds) = seqDemand d `seq` seqDemands ds %************************************************************************ \begin{code} +isLazy :: Demand -> Bool + -- Even a demand of (WwUnpack NewType _ _) is strict + -- We don't create such a thing unless the demand inside is strict +isLazy (WwLazy _) = True +isLazy _ = False + isStrict :: Demand -> Bool -isStrict (WwUnpack NewType _ ds) = isStrict (head ds) -isStrict (WwUnpack other _ _) = True -isStrict WwStrict = True -isStrict WwEnum = True -isStrict WwPrim = True -isStrict _ = False +isStrict d = not (isLazy d) isPrim :: Demand -> Bool isPrim WwPrim = True isPrim other = False \end{code} -\begin{code} -isLazy :: Demand -> Bool -isLazy (WwLazy False) = True -- NB "Absent" args do *not* count! -isLazy _ = False -- (as they imply a worker) -\end{code} - %************************************************************************ %* * @@ -174,6 +170,7 @@ data StrictnessInfo -- BUT NB: f = \x y. error "urk" -- will have info SI [SS] True -- but still (f) and (f 2) are not bot; only (f 3 2) is bot + deriving( Eq ) -- NOTA BENE: if the arg demands are, say, [S,L], this means that -- (f bot) is not necy bot, only (f bot x) is bot @@ -191,8 +188,11 @@ seqStrictnessInfo other = () mkStrictnessInfo :: ([Demand], Bool) -> StrictnessInfo mkStrictnessInfo (xs, is_bot) - | all isLazy xs && not is_bot = NoStrictnessInfo -- Uninteresting - | otherwise = StrictnessInfo xs is_bot + | all totally_boring xs && not is_bot = NoStrictnessInfo -- Uninteresting + | otherwise = StrictnessInfo xs is_bot + where + totally_boring (WwLazy False) = True + totally_boring other = False noStrictnessInfo = NoStrictnessInfo @@ -203,8 +203,7 @@ isBottomingStrictness NoStrictnessInfo = False appIsBottom (StrictnessInfo ds bot) n = bot && (n >= length ds) appIsBottom NoStrictnessInfo n = False -ppStrictnessInfo NoStrictnessInfo = empty -ppStrictnessInfo (StrictnessInfo wrapper_args bot) - = hsep [ptext SLIT("__S"), pprDemands wrapper_args bot] +ppStrictnessInfo NoStrictnessInfo = empty +ppStrictnessInfo (StrictnessInfo wrapper_args bot) = hsep [pprDemands wrapper_args bot] \end{code} diff --git a/ghc/compiler/basicTypes/Id.lhs b/ghc/compiler/basicTypes/Id.lhs index 26bd7991f6..0076c36bf8 100644 --- a/ghc/compiler/basicTypes/Id.lhs +++ b/ghc/compiler/basicTypes/Id.lhs @@ -95,7 +95,7 @@ import OccName ( UserFS ) import PrimRep ( PrimRep ) import PrimOp ( PrimOp, primOpIsCheap ) import TysPrim ( statePrimTyCon ) -import FieldLabel ( FieldLabel(..) ) +import FieldLabel ( FieldLabel ) import SrcLoc ( SrcLoc ) import Unique ( Unique, mkBuiltinUnique, getBuiltinUniques ) import Outputable diff --git a/ghc/compiler/basicTypes/IdInfo.lhs b/ghc/compiler/basicTypes/IdInfo.lhs index 502a904913..8cc168dd0a 100644 --- a/ghc/compiler/basicTypes/IdInfo.lhs +++ b/ghc/compiler/basicTypes/IdInfo.lhs @@ -290,6 +290,7 @@ data ArityInfo -- functions in the module being compiled. Their arity -- might increase later in the compilation process, if -- an extra lambda floats up to the binding site. + deriving( Eq ) seqArity :: ArityInfo -> () seqArity a = arityLowerBound a `seq` () @@ -323,6 +324,7 @@ data InlinePragInfo = NoInlinePragInfo | IMustNotBeINLINEd Bool -- True <=> came from an INLINE prag, False <=> came from a NOINLINE prag (Maybe Int) -- Phase number from pragma, if any + deriving( Eq ) -- The True, Nothing case doesn't need to be recorded -- SEE COMMENTS WITH CoreUnfold.blackListed on the diff --git a/ghc/compiler/basicTypes/Literal.lhs b/ghc/compiler/basicTypes/Literal.lhs index 5356710097..ca14f9a969 100644 --- a/ghc/compiler/basicTypes/Literal.lhs +++ b/ghc/compiler/basicTypes/Literal.lhs @@ -8,7 +8,7 @@ module Literal ( Literal(..) -- Exported to ParseIface , mkMachInt, mkMachWord , mkMachInt64, mkMachWord64 - , isLitLitLit + , isLitLitLit, maybeLitLit , literalType, literalPrimRep , hashLiteral @@ -38,10 +38,6 @@ import Util ( thenCmp ) import Ratio ( numerator, denominator ) import FastString ( uniqueOfFS ) import Char ( ord, chr ) - -#if __GLASGOW_HASKELL__ >= 404 -import GlaExts ( fromInt ) -#endif \end{code} @@ -179,6 +175,9 @@ double2FloatLit (MachDouble d) = MachFloat d \begin{code} isLitLitLit (MachLitLit _ _) = True isLitLitLit _ = False + +maybeLitLit (MachLitLit s t) = Just (s,t) +maybeLitLit _ = Nothing \end{code} Types diff --git a/ghc/compiler/basicTypes/MkId.lhs b/ghc/compiler/basicTypes/MkId.lhs index 3206e03f28..9c52fdd38e 100644 --- a/ghc/compiler/basicTypes/MkId.lhs +++ b/ghc/compiler/basicTypes/MkId.lhs @@ -37,7 +37,7 @@ import TysPrim ( openAlphaTyVars, alphaTyVar, alphaTy, intPrimTy, realWorldStatePrimTy ) import TysWiredIn ( boolTy, charTy, mkListTy ) -import PrelMods ( pREL_ERR, pREL_GHC ) +import PrelNames ( pREL_ERR, pREL_GHC ) import PrelRules ( primOpRule ) import Rules ( addRule ) import Type ( Type, ClassContext, mkDictTy, mkDictTys, mkTyConApp, mkTyVarTys, @@ -51,6 +51,7 @@ import PprType ( pprParendType ) import Module ( Module ) import CoreUtils ( exprType, mkInlineMe ) import CoreUnfold ( mkTopUnfolding, mkCompulsoryUnfolding, mkOtherCon ) +import Literal ( Literal(..) ) import Subst ( mkTopTyVarSubst, substClasses ) import TyCon ( TyCon, isNewTyCon, tyConTyVars, tyConDataCons, isDataTyCon, tyConTheta, isProductTyCon, isUnboxedTupleTyCon ) @@ -66,7 +67,7 @@ import PrimOp ( PrimOp(DataToTagOp, CCallOp), primOpSig, mkPrimOpIdName, CCall, pprCCallOp ) -import Demand ( wwStrict, wwPrim ) +import Demand ( wwStrict, wwPrim, mkStrictnessInfo ) import DataCon ( DataCon, StrictnessMark(..), dataConFieldLabels, dataConRepArity, dataConTyCon, dataConArgTys, dataConRepType, dataConRepStrictness, @@ -168,7 +169,7 @@ mkDataConId work_name data_con arity = dataConRepArity data_con - strict_info = StrictnessInfo (dataConRepStrictness data_con) False + strict_info = mkStrictnessInfo (dataConRepStrictness data_con, False) cpr_info | isProductTyCon tycon && not (isUnboxedTupleTyCon tycon) && @@ -373,9 +374,11 @@ Similarly for newtypes unN = /\a -> \n:N -> coerce (a->a) n \begin{code} -mkRecordSelId tycon field_label - -- Assumes that all fields with the same field label - -- have the same type +mkRecordSelId tycon field_label unpack_id + -- 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 = mkId (fieldLabelName field_label) selector_ty info @@ -441,8 +444,9 @@ mkRecordSelId tycon field_label field_lbls = dataConFieldLabels data_con maybe_the_arg_id = assocMaybe (field_lbls `zip` arg_ids) field_label - error_expr = mkApps (Var rEC_SEL_ERROR_ID) [Type (unUsgTy field_tau), mkStringLit full_msg] + error_expr = mkApps (Var rEC_SEL_ERROR_ID) [Type (unUsgTy field_tau), err_string] -- preserves invariant that type args are *not* usage-annotated on top. KSW 1999-04. + err_string = App (Var unpack_id) (Lit (MachStr (_PK_ full_msg))) full_msg = showSDoc (sep [text "No match in record selector", ppr sel_id]) \end{code} @@ -459,6 +463,7 @@ there's nothing to do. ToDo: unify with mkRecordSelId. \begin{code} +mkDictSelId :: Name -> Class -> Id mkDictSelId name clas = sel_id where diff --git a/ghc/compiler/basicTypes/Module.lhs b/ghc/compiler/basicTypes/Module.lhs index 2650e2e537..92877df6e8 100644 --- a/ghc/compiler/basicTypes/Module.lhs +++ b/ghc/compiler/basicTypes/Module.lhs @@ -5,6 +5,19 @@ Representing modules and their flavours. + +Notes on DLLs +~~~~~~~~~~~~~ +When compiling module A, which imports module B, we need to +know whether B will be in the same DLL as A. + If it's in the same DLL, we refer to B_f_closure + If it isn't, we refer to _imp__B_f_closure +When compiling A, we record in B's Module value whether it's +in a different DLL, by setting the DLL flag. + + + + \begin{code} module Module ( @@ -93,27 +106,6 @@ instance Show PackageInfo where -- Just used in debug prints of lex tokens %************************************************************************ %* * -\subsection{System/user module} -%* * -%************************************************************************ - -We also track whether an imported module is from a 'system-ish' place. In this case -we don't record the fact that this module depends on it, nor usages of things -inside it. - -Apr 00: We want to record dependencies on all modules other than -prelude modules else STG Hugs gets confused because it uses this -info to know what modules to link. (Compiled GHC uses command line -options to specify this.) - -\begin{code} -data ModFlavour = PrelMod -- A Prelude module - | UserMod -- Not library-ish -\end{code} - - -%************************************************************************ -%* * \subsection{Where from} %* * %************************************************************************ @@ -201,6 +193,7 @@ mkModule mod_nm pack_name pack_info | pack_name == opt_InPackage = ThisPackage | otherwise = AnotherPackage pack_name + mkVanillaModule :: ModuleName -> Module mkVanillaModule name = Module name ThisPackage -- Used temporarily when we first come across Foo.x in an interface diff --git a/ghc/compiler/basicTypes/Name.lhs b/ghc/compiler/basicTypes/Name.lhs index 83508b525a..ff8096a929 100644 --- a/ghc/compiler/basicTypes/Name.lhs +++ b/ghc/compiler/basicTypes/Name.lhs @@ -21,7 +21,7 @@ module Name ( nameUnique, setNameUnique, setNameProvenance, getNameProvenance, setNameImportReason, tidyTopName, - nameOccName, nameModule, setNameOcc, nameRdrName, setNameModule, + nameOccName, nameModule, setNameOcc, nameRdrName, setNameModule, toRdrName, isUserExportedName, isUserImportedName, isUserImportedExplicitlyName, maybeUserImportedFrom, @@ -29,6 +29,13 @@ module Name ( isSystemName, isLocalName, isGlobalName, isExternallyVisibleName, + -- Environment + NameEnv, + emptyNameEnv, unitNameEnv, nameEnvElts, + addToNameEnv_C, addToNameEnv, addListToNameEnv, + plusNameEnv, plusNameEnv_C, extendNameEnv, + lookupNameEnv, delFromNameEnv, elemNameEnv, + -- Provenance Provenance(..), ImportReason(..), pprProvenance, @@ -51,7 +58,8 @@ import RdrName ( RdrName, mkRdrQual, mkRdrUnqual, rdrNameOcc, rdrNameModule ) import CmdLineOpts ( opt_Static, opt_PprStyle_NoPrags, opt_OmitInterfacePragmas, opt_EnsureSplittableC ) import SrcLoc ( noSrcLoc, mkBuiltinSrcLoc, SrcLoc ) -import Unique ( pprUnique, Unique, Uniquable(..), unboundKey, u2i ) +import Unique ( pprUnique, Unique, Uniquable(..), hasKey, unboundKey, u2i ) +import UniqFM import Outputable import GlaExts \end{code} @@ -179,7 +187,7 @@ mkUnboundName :: RdrName -> Name mkUnboundName rdr_name = mkLocalName unboundKey (rdrNameOcc rdr_name) noSrcLoc isUnboundName :: Name -> Bool -isUnboundName name = getUnique name == unboundKey +isUnboundName name = name `hasKey` unboundKey \end{code} \begin{code} @@ -420,6 +428,8 @@ nameSortModule (WiredInId mod _) = mod nameSortModule (WiredInTyCon mod _) = mod nameRdrName :: Name -> RdrName +-- Makes a qualified name for top-level (Global) names, whether locally defined or not +-- and an unqualified name just for Locals nameRdrName (Name { n_sort = Local, n_occ = occ }) = mkRdrUnqual occ nameRdrName (Name { n_sort = sort, n_occ = occ }) = mkRdrQual (moduleName (nameSortModule sort)) occ @@ -486,13 +496,16 @@ isGlobalName other = True isExternallyVisibleName name = isGlobalName name hasBetterProv :: Name -> Name -> Bool -hasBetterProv name1 name2 - = case n_prov name1 of - LocalDef _ _ -> True - SystemProv -> False - NonLocalDef _ _ -> case n_prov name2 of - LocalDef _ _ -> False - other -> True +-- 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 n1 n2 + = case (n_prov n1, n_prov n2) of + (LocalDef _ _, _ ) -> True + (NonLocalDef (UserImport _ _ True) _, _ ) -> True + (NonLocalDef (UserImport _ _ _ ) _, NonLocalDef ImplicitImport _) -> True + other -> False isSystemName (Name {n_prov = SystemProv}) = True isSystemName other = False @@ -531,6 +544,43 @@ instance NamedThing Name where %************************************************************************ %* * +\subsection{Name environment} +%* * +%************************************************************************ + +\begin{code} +type NameEnv a = UniqFM a -- Domain is Name + +emptyNameEnv :: NameEnv a +nameEnvElts :: NameEnv a -> [a] +addToNameEnv_C :: (a->a->a) -> NameEnv a -> Name -> a -> NameEnv a +addToNameEnv :: NameEnv a -> Name -> a -> NameEnv a +addListToNameEnv :: NameEnv a -> [(Name,a)] -> NameEnv a +plusNameEnv :: NameEnv a -> NameEnv a -> NameEnv a +plusNameEnv_C :: (a->a->a) -> NameEnv a -> NameEnv a -> NameEnv a +extendNameEnv :: NameEnv a -> [(Name,a)] -> NameEnv a +lookupNameEnv :: NameEnv a -> Name -> Maybe a +delFromNameEnv :: NameEnv a -> Name -> NameEnv a +elemNameEnv :: Name -> NameEnv a -> Bool +unitNameEnv :: Name -> a -> NameEnv a + +emptyNameEnv = emptyUFM +nameEnvElts = eltsUFM +addToNameEnv_C = addToUFM_C +addToNameEnv = addToUFM +addListToNameEnv = addListToUFM +plusNameEnv = plusUFM +plusNameEnv_C = plusUFM_C +extendNameEnv = addListToUFM +lookupNameEnv = lookupUFM +delFromNameEnv = delFromUFM +elemNameEnv = elemUFM +unitNameEnv = unitUFM +\end{code} + + +%************************************************************************ +%* * \subsection{Pretty printing} %* * %************************************************************************ diff --git a/ghc/compiler/basicTypes/OccName.lhs b/ghc/compiler/basicTypes/OccName.lhs index d52773be47..98eb7c17dd 100644 --- a/ghc/compiler/basicTypes/OccName.lhs +++ b/ghc/compiler/basicTypes/OccName.lhs @@ -69,7 +69,14 @@ pprEncodedFS :: EncodedFS -> SDoc pprEncodedFS fs = getPprStyle $ \ sty -> if userStyle sty then - text (decode (_UNPK_ fs)) + let + s = decode (_UNPK_ fs) + c = head s + in + if startsVarSym c || startsConSym c then + parens (text s) + else + text s else ptext fs \end{code} @@ -614,32 +621,29 @@ isLexSym cs = isLexConSym cs || isLexVarSym cs isLexConId cs -- Prefix type or data constructors | _NULL_ cs = False -- e.g. "Foo", "[]", "(,)" | cs == SLIT("[]") = True - | c == '(' = True -- (), (,), (,,), ... - | otherwise = isUpper c || isUpperISO c - where - c = _HEAD_ cs + | otherwise = startsConId (_HEAD_ cs) isLexVarId cs -- Ordinary prefix identifiers | _NULL_ cs = False -- e.g. "x", "_x" - | otherwise = isLower c || isLowerISO c || c == '_' - where - c = _HEAD_ cs + | otherwise = startsVarId (_HEAD_ cs) isLexConSym cs -- Infix type or data constructors | _NULL_ cs = False -- e.g. ":-:", ":", "->" - | otherwise = c == ':' - || cs == SLIT("->") - where - c = _HEAD_ cs + | cs == SLIT("->") = True + | otherwise = startsConSym (_HEAD_ cs) isLexVarSym cs -- Infix identifiers | _NULL_ cs = False -- e.g. "+" - | otherwise = isSymbolASCII c - || isSymbolISO c - where - c = _HEAD_ cs + | otherwise = startsVarSym (_HEAD_ cs) ------------- +startsVarSym, startsVarId, startsConSym, startsConId :: Char -> Bool +startsVarSym c = isSymbolASCII c || isSymbolISO c -- Infix Ids +startsConSym c = c == ':' -- Infix data constructors +startsVarId c = isLower c || isLowerISO c || c == '_' -- Ordinary Ids +startsConId c = isUpper c || isUpperISO c || c == '(' -- Ordinary type constructors and data constructors + + isSymbolASCII c = c `elem` "!#$%&*+./<=>?@\\^|~-" isSymbolISO c = ord c `elem` (0xd7 : 0xf7 : [0xa1 .. 0xbf]) isUpperISO (C# c#) = c# `geChar#` '\xc0'# && c# `leChar#` '\xde'# && c# `neChar#` '\xd7'# diff --git a/ghc/compiler/basicTypes/RdrName.lhs b/ghc/compiler/basicTypes/RdrName.lhs index 0db2b48901..8686f708b4 100644 --- a/ghc/compiler/basicTypes/RdrName.lhs +++ b/ghc/compiler/basicTypes/RdrName.lhs @@ -17,7 +17,15 @@ module RdrName ( -- Destruction rdrNameModule, rdrNameOcc, setRdrNameOcc, - isRdrDataCon, isRdrTyVar, isQual, isUnqual + isRdrDataCon, isRdrTyVar, isQual, isUnqual, + + -- Environment + RdrNameEnv, + emptyRdrEnv, lookupRdrEnv, addListToRdrEnv, rdrEnvElts, + extendRdrEnv, rdrEnvToList, + + -- Printing; instance Outputable RdrName + pprUnqualRdrName ) where #include "HsVersions.h" @@ -31,6 +39,7 @@ import OccName ( NameSpace, tcName, import Module ( ModuleName, pprModuleName, mkSysModuleFS, mkSrcModuleFS ) +import FiniteMap import Outputable import Util ( thenCmp ) \end{code} @@ -134,8 +143,10 @@ isQual rdr_name = not (isUnqual rdr_name) instance Outputable RdrName where ppr (RdrName qual occ) = pp_qual qual <> ppr occ where - pp_qual Unqual = empty - pp_qual (Qual mod) = pprModuleName mod <> dot + pp_qual Unqual = empty + pp_qual (Qual mod) = pprModuleName mod <> dot + +pprUnqualRdrName (RdrName qual occ) = ppr occ instance Eq RdrName where a == b = case (a `compare` b) of { EQ -> True; _ -> False } @@ -159,3 +170,26 @@ cmpQual (Qual m1) (Qual m2) = m1 `compare` m2 +%************************************************************************ +%* * +\subsection{Environment} +%* * +%************************************************************************ + +\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] + +emptyRdrEnv = emptyFM +lookupRdrEnv = lookupFM +addListToRdrEnv = addListToFM +rdrEnvElts = eltsFM +extendRdrEnv = addToFM +rdrEnvToList = fmToList +\end{code} diff --git a/ghc/compiler/basicTypes/Unique.lhs b/ghc/compiler/basicTypes/Unique.lhs index a04fbd6f69..8850936eb3 100644 --- a/ghc/compiler/basicTypes/Unique.lhs +++ b/ghc/compiler/basicTypes/Unique.lhs @@ -16,7 +16,7 @@ Haskell). \begin{code} module Unique ( - Unique, Uniquable(..), + Unique, Uniquable(..), hasKey, u2i, -- hack: used in UniqFM pprUnique, pprUnique10, @@ -30,16 +30,14 @@ module Unique ( initTyVarUnique, initTidyUniques, - isTupleKey, + isTupleKey, -- now all the built-in Uniques (and functions to make them) -- [the Oh-So-Wonderful Haskell module system wins again...] mkAlphaTyVarUnique, mkPrimOpIdUnique, mkTupleDataConUnique, - mkUbxTupleDataConUnique, mkTupleTyConUnique, - mkUbxTupleTyConUnique, getBuiltinUniques, mkBuiltinUnique, mkPseudoUnique1, mkPseudoUnique2, mkPseudoUnique3, @@ -198,6 +196,7 @@ module Unique ( #include "HsVersions.h" +import BasicTypes ( Boxity(..) ) import FastString ( FastString, uniqueOfFS ) import GlaExts import ST @@ -290,6 +289,9 @@ unpkUnique (MkUnique u) class Uniquable a where getUnique :: a -> Unique +hasKey :: Uniquable a => a -> Unique -> Bool +x `hasKey` k = getUnique x == k + instance Uniquable FastString where getUnique fs = mkUniqueGrimily (uniqueOfFS fs) @@ -430,8 +432,8 @@ mkAlphaTyVarUnique i = mkUnique '1' i mkPreludeClassUnique i = mkUnique '2' i mkPreludeTyConUnique i = mkUnique '3' i -mkTupleTyConUnique a = mkUnique '4' a -mkUbxTupleTyConUnique a = mkUnique '5' a +mkTupleTyConUnique Boxed a = mkUnique '4' a +mkTupleTyConUnique Unboxed a = mkUnique '5' a -- Data constructor keys occupy *two* slots. The first is used for the -- data constructor itself and its wrapper function (the function that @@ -440,8 +442,8 @@ mkUbxTupleTyConUnique a = mkUnique '5' a -- representation). mkPreludeDataConUnique i = mkUnique '6' (2*i) -- Must be alphabetic -mkTupleDataConUnique a = mkUnique '7' (2*a) -- ditto (*may* be used in C labels) -mkUbxTupleDataConUnique a = mkUnique '8' (2*a) +mkTupleDataConUnique Boxed a = mkUnique '7' (2*a) -- ditto (*may* be used in C labels) +mkTupleDataConUnique Unboxed a = mkUnique '8' (2*a) -- This one is used for a tiresome reason -- to improve a consistency-checking error check in the renamer diff --git a/ghc/compiler/codeGen/CgCase.lhs b/ghc/compiler/codeGen/CgCase.lhs index b9c3149194..d64755b4b8 100644 --- a/ghc/compiler/codeGen/CgCase.lhs +++ b/ghc/compiler/codeGen/CgCase.lhs @@ -1,7 +1,7 @@ % % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % -% $Id: CgCase.lhs,v 1.41 2000/04/13 20:41:30 panne Exp $ +% $Id: CgCase.lhs,v 1.42 2000/05/25 12:41:15 simonpj Exp $ % %******************************************************** %* * @@ -59,7 +59,7 @@ import PrimRep ( getPrimRepSize, retPrimRepSize, PrimRep(..) ) import TyCon ( TyCon, isEnumerationTyCon, isUnboxedTupleTyCon, isNewTyCon, isAlgTyCon, isFunTyCon, isPrimTyCon, - tyConDataCons, tyConFamilySize ) + ) import Type ( Type, typePrimRep, splitAlgTyConApp, splitTyConApp_maybe, repType ) import PprType ( {- instance Outputable Type -} ) diff --git a/ghc/compiler/codeGen/CgRetConv.lhs b/ghc/compiler/codeGen/CgRetConv.lhs index f02b4d6590..e292ea1d9f 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.21 2000/04/05 16:25:51 simonpj Exp $ +% $Id: CgRetConv.lhs,v 1.22 2000/05/25 12:41:15 simonpj Exp $ % \section[CgRetConv]{Return conventions for the code generator} @@ -30,7 +30,7 @@ import Maybes ( catMaybes ) import DataCon ( DataCon ) import PrimOp ( PrimOp{-instance Outputable-} ) import PrimRep ( isFloatingRep, PrimRep(..), is64BitRep ) -import TyCon ( TyCon, tyConDataCons, tyConFamilySize ) +import TyCon ( TyCon, tyConFamilySize ) import Type ( Type, typePrimRep, isUnLiftedType ) import Util ( isn'tIn ) diff --git a/ghc/compiler/codeGen/ClosureInfo.lhs b/ghc/compiler/codeGen/ClosureInfo.lhs index d107e7eb61..302dbc4438 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.41 2000/04/05 15:17:38 simonmar Exp $ +% $Id: ClosureInfo.lhs,v 1.42 2000/05/25 12:41:15 simonpj Exp $ % \section[ClosureInfo]{Data structures which describe closures} @@ -81,8 +81,9 @@ import CmdLineOpts ( opt_SccProfilingOn, opt_OmitBlackHoling, opt_SMP ) import Id ( Id, idType, idArityInfo ) import DataCon ( DataCon, dataConTag, fIRST_TAG, dataConTyCon, - isNullaryDataCon, isTupleCon, dataConName + isNullaryDataCon, dataConName ) +import TyCon ( isBoxedTupleTyCon ) import IdInfo ( ArityInfo(..) ) import Name ( Name, isExternallyVisibleName, nameUnique, getOccName ) @@ -238,7 +239,8 @@ mkConLFInfo :: DataCon -> LambdaFormInfo mkConLFInfo con = -- the isNullaryDataCon will do this: ASSERT(isDataCon con) - (if isTupleCon con then LFTuple else LFCon) con (isNullaryDataCon con) + (if isBoxedTupleTyCon (dataConTyCon con) then LFTuple else LFCon) + con (isNullaryDataCon con) mkSelectorLFInfo rhs_ty offset updatable = LFThunk rhs_ty NotTopLevel False updatable (SelectorThunk offset) diff --git a/ghc/compiler/coreSyn/CoreFVs.lhs b/ghc/compiler/coreSyn/CoreFVs.lhs index 3c4d5c87c9..57844395ca 100644 --- a/ghc/compiler/coreSyn/CoreFVs.lhs +++ b/ghc/compiler/coreSyn/CoreFVs.lhs @@ -7,7 +7,10 @@ Taken quite directly from the Peyton Jones/Lester paper. module CoreFVs ( exprFreeVars, exprsFreeVars, exprSomeFreeVars, exprsSomeFreeVars, - idRuleVars, idFreeVars, ruleSomeFreeVars, ruleSomeLhsFreeVars, + idRuleVars, idFreeVars, + ruleSomeFreeVars, ruleSomeLhsFreeVars, ruleRhsFreeVars, + + mustHaveLocalBinding, CoreExprWithFVs, CoreBindWithFVs, freeVars, freeVarsOf, ) where @@ -15,14 +18,30 @@ module CoreFVs ( #include "HsVersions.h" import CoreSyn -import Id ( Id, idFreeTyVars, idSpecialisation ) +import Id ( Id, idFreeTyVars, mayHaveNoBinding, idSpecialisation ) import VarSet import Var ( Var, isId ) import Name ( isLocallyDefined ) import Type ( tyVarsOfType, Type ) import Util ( mapAndUnzip ) +import Outputable +\end{code} + +%************************************************************************ +%* * +\section{Utilities} +%* * +%************************************************************************ + +\begin{code} +mustHaveLocalBinding :: Var -> Bool +-- True <=> the variable must have a binding in this module +mustHaveLocalBinding v + | isId v = isLocallyDefined v && not (mayHaveNoBinding v) + | otherwise = True -- TyVars etc must \end{code} + %************************************************************************ %* * \section{Finding the free variables of an expression} @@ -75,9 +94,10 @@ noVars fv_cand in_scope = emptyVarSet -- is a little weird. The reason is that the former is more efficient, -- but the latter is more fine grained, and a makes a difference when -- a variable mentions itself one of its own rule RHSs -oneVar :: Var -> FV +oneVar :: Id -> FV oneVar var fv_cand in_scope - = foldVarSet add_rule_var var_itself_set (idRuleVars var) + = ASSERT( isId var ) + foldVarSet add_rule_var var_itself_set (idRuleVars var) where var_itself_set | keep_it fv_cand in_scope var = unitVarSet var | otherwise = emptyVarSet @@ -134,15 +154,22 @@ expr_fvs (Let (Rec pairs) body) \begin{code} idRuleVars ::Id -> VarSet -idRuleVars id = rulesRhsFreeVars (idSpecialisation id) +idRuleVars id = ASSERT( isId id) rulesRhsFreeVars (idSpecialisation id) idFreeVars :: Id -> VarSet -idFreeVars id = idRuleVars id `unionVarSet` idFreeTyVars id +idFreeVars id = ASSERT( isId id) idRuleVars id `unionVarSet` idFreeTyVars id rulesSomeFreeVars :: InterestingVarFun -> CoreRules -> VarSet rulesSomeFreeVars interesting (Rules rules _) = foldr (unionVarSet . ruleSomeFreeVars interesting) emptyVarSet rules +ruleRhsFreeVars :: CoreRule -> VarSet +ruleRhsFreeVars (BuiltinRule _) = noFVs +ruleRhsFreeVars (Rule str tpl_vars tpl_args rhs) + = rule_fvs isLocallyDefined emptyVarSet + where + rule_fvs = addBndrs tpl_vars (expr_fvs rhs) + ruleSomeFreeVars :: InterestingVarFun -> CoreRule -> VarSet ruleSomeFreeVars interesting (BuiltinRule _) = noFVs ruleSomeFreeVars interesting (Rule _ tpl_vars tpl_args rhs) diff --git a/ghc/compiler/coreSyn/CoreLint.lhs b/ghc/compiler/coreSyn/CoreLint.lhs index 3dc98933d2..9b45e65dad 100644 --- a/ghc/compiler/coreSyn/CoreLint.lhs +++ b/ghc/compiler/coreSyn/CoreLint.lhs @@ -16,13 +16,13 @@ import IO ( hPutStr, hPutStrLn, stderr, stdout ) import CmdLineOpts ( opt_D_show_passes, opt_DoCoreLinting, opt_PprStyle_Debug ) import CoreSyn -import CoreFVs ( idFreeVars ) +import CoreFVs ( idFreeVars, mustHaveLocalBinding ) import CoreUtils ( exprOkForSpeculation, coreBindsSize ) import Bag import Literal ( Literal, literalType ) import DataCon ( DataCon, dataConRepType ) -import Id ( mayHaveNoBinding, isDeadBinder ) +import Id ( isDeadBinder ) import Var ( Var, Id, TyVar, idType, tyVarKind, isTyVar, isId ) import VarSet import Subst ( mkTyVarSubst, substTy ) @@ -561,19 +561,7 @@ checkBndrIdInScope binder id checkInScope :: SDoc -> Var -> LintM () checkInScope loc_msg var loc scope errs - | isLocallyDefined var - && not (var `elemVarSet` scope) - && not (isId var && mayHaveNoBinding var) - -- Micro-hack here... Class decls generate applications of their - -- dictionary constructor, but don't generate a binding for the - -- constructor (since it would never be used). After a single round - -- of simplification, these dictionary constructors have been - -- inlined (from their UnfoldInfo) to CoCons. Just between - -- desugaring and simplfication, though, they appear as naked, unbound - -- variables as the function in an application. - -- The hack here simply doesn't check for out-of-scope-ness for - -- data constructors (at least, in a function position). - -- Ditto primitive Ids + | mustHaveLocalBinding var && not (var `elemVarSet` scope) = (Nothing, addErr errs (hsep [ppr var, loc_msg]) loc) | otherwise = (Nothing,errs) diff --git a/ghc/compiler/coreSyn/CoreSyn.lhs b/ghc/compiler/coreSyn/CoreSyn.lhs index ebe3177c48..fa08ba481f 100644 --- a/ghc/compiler/coreSyn/CoreSyn.lhs +++ b/ghc/compiler/coreSyn/CoreSyn.lhs @@ -12,7 +12,7 @@ module CoreSyn ( mkLets, mkLams, mkApps, mkTyApps, mkValApps, mkVarApps, mkLit, mkIntLitInt, mkIntLit, - mkStringLit, mkStringLitFS, mkConApp, + mkConApp, varToCoreExpr, bindersOf, bindersOfBinds, rhssOfBind, rhssOfAlts, isTyVar, isId, @@ -40,7 +40,8 @@ module CoreSyn ( CoreRules(..), -- Representation needed by friends CoreRule(..), -- CoreSubst, CoreTidy, CoreFVs, PprCore only RuleName, - emptyCoreRules, isEmptyCoreRules, rulesRhsFreeVars, rulesRules + emptyCoreRules, isEmptyCoreRules, rulesRhsFreeVars, rulesRules, + isBuiltinRule ) where #include "HsVersions.h" @@ -52,7 +53,6 @@ import Type ( Type, UsageAnn, mkTyVarTy, isUnLiftedType, seqType ) import Literal ( Literal(MachStr), mkMachInt ) import PrimOp ( PrimOp ) import DataCon ( DataCon, dataConId ) -import ThinAir ( unpackCStringId, unpackCString2Id ) import VarSet import Outputable \end{code} @@ -124,6 +124,20 @@ data CoreRules = Rules [CoreRule] VarSet -- Locally-defined free vars of RHSs +emptyCoreRules :: CoreRules +emptyCoreRules = Rules [] emptyVarSet + +isEmptyCoreRules :: CoreRules -> Bool +isEmptyCoreRules (Rules rs _) = null rs + +rulesRhsFreeVars :: CoreRules -> VarSet +rulesRhsFreeVars (Rules _ fvs) = fvs + +rulesRules :: CoreRules -> [CoreRule] +rulesRules (Rules rules _) = rules +\end{code} + +\begin{code} type RuleName = FAST_STRING data CoreRule @@ -136,17 +150,8 @@ data CoreRule -- and suchlike. It has no free variables. ([CoreExpr] -> Maybe (RuleName, CoreExpr)) -emptyCoreRules :: CoreRules -emptyCoreRules = Rules [] emptyVarSet - -isEmptyCoreRules :: CoreRules -> Bool -isEmptyCoreRules (Rules rs _) = null rs - -rulesRhsFreeVars :: CoreRules -> VarSet -rulesRhsFreeVars (Rules _ fvs) = fvs - -rulesRules :: CoreRules -> [CoreRule] -rulesRules (Rules rules _) = rules +isBuiltinRule (BuiltinRule _) = True +isBuiltinRule _ = False \end{code} @@ -329,8 +334,6 @@ mkVarApps f vars = foldl (\ e a -> App e (varToCoreExpr a)) f vars mkLit :: Literal -> Expr b mkIntLit :: Integer -> Expr b mkIntLitInt :: Int -> Expr b -mkStringLit :: String -> Expr b -- Makes a [Char] literal -mkStringLitFS :: FAST_STRING -> Expr b -- Makes a [Char] literal mkConApp :: DataCon -> [Arg b] -> Expr b mkLets :: [Bind b] -> Expr b -> Expr b mkLams :: [b] -> Expr b -> Expr b @@ -344,22 +347,6 @@ mkLets binds body = foldr Let body binds mkIntLit n = Lit (mkMachInt n) mkIntLitInt n = Lit (mkMachInt (toInteger n)) -mkStringLit str = mkStringLitFS (_PK_ str) - -mkStringLitFS str - | any is_NUL (_UNPK_ str) - = -- Must cater for NULs in literal string - mkApps (Var unpackCString2Id) - [Lit (MachStr str), - mkIntLitInt (_LENGTH_ str)] - - | otherwise - = -- No NULs in the string - App (Var unpackCStringId) (Lit (MachStr str)) - - where - is_NUL c = c == '\0' - varToCoreExpr :: CoreBndr -> Expr b varToCoreExpr v | isId v = Var v | otherwise = Type (mkTyVarTy v) diff --git a/ghc/compiler/coreSyn/CoreUnfold.lhs b/ghc/compiler/coreSyn/CoreUnfold.lhs index 7276e3480d..480edbb505 100644 --- a/ghc/compiler/coreSyn/CoreUnfold.lhs +++ b/ghc/compiler/coreSyn/CoreUnfold.lhs @@ -46,7 +46,7 @@ import PprCore ( pprCoreExpr ) import OccurAnal ( occurAnalyseGlobalExpr ) import BinderInfo ( ) import CoreUtils ( exprIsValue, exprIsCheap, exprIsBottom, exprIsTrivial ) -import Id ( Id, idType, idFlavour, idUnique, isId, idWorkerInfo, +import Id ( Id, idType, idFlavour, isId, idWorkerInfo, idSpecialisation, idInlinePragma, idUnfolding, isPrimOpId_maybe ) @@ -57,9 +57,8 @@ import PrimOp ( PrimOp(..), primOpIsDupable, primOpOutOfLine, ccallIsCasm ) import IdInfo ( ArityInfo(..), InlinePragInfo(..), OccInfo(..), IdFlavour(..), CprInfo(..), insideLam, workerExists, isNeverInlinePrag ) -import TyCon ( tyConFamilySize ) import Type ( splitFunTy_maybe, isUnLiftedType ) -import Unique ( Unique, buildIdKey, augmentIdKey ) +import Unique ( Unique, buildIdKey, augmentIdKey, hasKey ) import Maybes ( maybeToBool ) import Bag import List ( maximumBy ) @@ -279,8 +278,8 @@ sizeExpr (I# bOMB_OUT_SIZE) top_args expr -- Also if the function is a constant Id (constr or primop) -- compute discounts specially size_up_fun (Var fun) args - | idUnique fun == buildIdKey = buildSize - | idUnique fun == augmentIdKey = augmentSize + | fun `hasKey` buildIdKey = buildSize + | fun `hasKey` augmentIdKey = augmentSize | otherwise = case idFlavour fun of DataConId dc -> conSizeN (valArgCount args) diff --git a/ghc/compiler/coreSyn/CoreUtils.lhs b/ghc/compiler/coreSyn/CoreUtils.lhs index 4992e535f5..64ddad21e2 100644 --- a/ghc/compiler/coreSyn/CoreUtils.lhs +++ b/ghc/compiler/coreSyn/CoreUtils.lhs @@ -5,18 +5,18 @@ \begin{code} module CoreUtils ( - exprType, coreAltsType, - -- Construction mkNote, mkInlineMe, mkSCC, mkCoerce, bindNonRec, mkIfThenElse, mkAltExpr, + -- Properties of expressions + exprType, coreAltsType, exprArity, exprIsBottom, exprIsDupable, exprIsTrivial, exprIsCheap, exprIsValue,exprOkForSpeculation, exprIsBig, - exprArity, exprIsConApp_maybe, - + exprIsConApp_maybe, idAppIsBottom, idAppIsCheap, + -- Expr transformation etaReduceExpr, exprEtaExpandArity, -- Size @@ -232,7 +232,6 @@ mkIfThenElse guard then_expr else_expr applications. Note that primop Ids aren't considered trivial unless - @exprIsBottom@ is true of expressions that are guaranteed to diverge diff --git a/ghc/compiler/coreSyn/PprCore.lhs b/ghc/compiler/coreSyn/PprCore.lhs index ce8adc2ebf..c6e847abe4 100644 --- a/ghc/compiler/coreSyn/PprCore.lhs +++ b/ghc/compiler/coreSyn/PprCore.lhs @@ -9,7 +9,8 @@ \begin{code} module PprCore ( - pprCoreExpr, pprParendExpr, pprIfaceUnfolding, + pprCoreExpr, pprParendExpr, + pprCoreBinding, pprCoreBindings, pprIdBndr, pprCoreBinding, pprCoreBindings, pprCoreRules, pprCoreRule ) where @@ -29,8 +30,10 @@ import IdInfo ( IdInfo, megaSeqIdInfo, occInfo, cprInfo, ppCprInfo, lbvarInfo, workerInfo, ppWorkerInfo ) -import DataCon ( isTupleCon, isUnboxedTupleCon ) +import DataCon ( dataConTyCon ) +import TyCon ( tupleTyConBoxity, isTupleTyCon ) import PprType ( pprParendType, pprTyVarBndr ) +import BasicTypes ( tupleParens ) import PprEnv import Outputable \end{code} @@ -66,6 +69,7 @@ pprCoreBindings = pprTopBinds pprCoreEnv pprCoreBinding = pprTopBind pprCoreEnv pprCoreExpr = ppr_noparend_expr pprCoreEnv pprParendExpr = ppr_parend_expr pprCoreEnv +pprArg = ppr_arg pprCoreEnv pprCoreEnv = initCoreEnv pprCoreBinder \end{code} @@ -73,16 +77,6 @@ pprCoreEnv = initCoreEnv pprCoreBinder Printer for unfoldings in interfaces ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ \begin{code} -pprIfaceUnfolding :: CoreExpr -> SDoc -pprIfaceUnfolding = ppr_parend_expr pprIfaceEnv - -- Notice that it's parenthesised - -pprIfaceArg = ppr_arg pprIfaceEnv - -pprIfaceEnv = initCoreEnv pprIfaceBinder -\end{code} - -\begin{code} instance Outputable b => Outputable (Bind b) where ppr bind = ppr_bind pprGenericEnv bind @@ -182,11 +176,13 @@ ppr_expr add_par pe expr@(App fun arg) Var f -> case isDataConId_maybe f of -- Notice that we print the *worker* -- for tuples in paren'd format. - Just dc | saturated && isTupleCon dc -> parens pp_tup_args - | saturated && isUnboxedTupleCon dc -> text "(#" <+> pp_tup_args <+> text "#)" - other -> add_par (hang (pOcc pe f) 4 pp_args) - where - saturated = length val_args == idArity f + Just dc | saturated && isTupleTyCon tc + -> tupleParens (tupleTyConBoxity tc) pp_tup_args + where + tc = dataConTyCon dc + saturated = length val_args == idArity f + + other -> add_par (hang (pOcc pe f) 4 pp_args) other -> add_par (hang (ppr_parend_expr pe fun) 4 pp_args) } @@ -282,15 +278,11 @@ ppr_expr add_par pe (Note (TermUsg u) expr) add_par (ppr u <+> ppr_noparend_expr pe expr) ppr_case_pat pe con@(DataAlt dc) args - | isTupleCon dc - = parens (hsep (punctuate comma (map ppr_bndr args))) <+> arrow - | isUnboxedTupleCon dc - = hsep [text "(# " <> - hsep (punctuate comma (map ppr_bndr args)) <> - text " #)", - arrow] + | isTupleTyCon tc + = tupleParens (tupleTyConBoxity tc) (hsep (punctuate comma (map ppr_bndr args))) <+> arrow where ppr_bndr = pBndr pe CaseBind + tc = dataConTyCon dc ppr_case_pat pe con args = ppr con <+> hsep (map ppr_bndr args) <+> arrow @@ -312,7 +304,7 @@ pprCoreBinder LetBind binder = vcat [sig, pragmas, ppr binder] where sig = pprTypedBinder binder - pragmas = ppIdInfo (idInfo binder) + pragmas = ppIdInfo binder (idInfo binder) -- Lambda bound type variables are preceded by "@" pprCoreBinder LambdaBind bndr = pprTypedBinder bndr @@ -320,10 +312,6 @@ pprCoreBinder LambdaBind bndr = pprTypedBinder bndr -- Case bound things don't get a signature or a herald pprCoreBinder CaseBind bndr = pprUntypedBinder bndr --- Used for printing interface-file unfoldings -pprIfaceBinder CaseBind binder = pprUntypedBinder binder -pprIfaceBinder other binder = pprTypedBinder binder - pprUntypedBinder binder | isTyVar binder = ptext SLIT("@") <+> pprTyVarBndr binder | otherwise = pprIdBndr binder @@ -347,8 +335,8 @@ pprIdBndr id = ppr id <+> \begin{code} -ppIdInfo :: IdInfo -> SDoc -ppIdInfo info +ppIdInfo :: Id -> IdInfo -> SDoc +ppIdInfo b info = hsep [ ppFlavourInfo (flavourInfo info), ppArityInfo a, @@ -357,7 +345,7 @@ ppIdInfo info ppStrictnessInfo s, ppCafInfo c, ppCprInfo m, - pprIfaceCoreRules p + pprCoreRules b p -- Inline pragma, occ, demand, lbvar info -- printed out with all binders (when debug is on); -- see PprCore.pprIdBndr @@ -374,24 +362,17 @@ ppIdInfo info \begin{code} pprCoreRules :: Id -> CoreRules -> SDoc -pprCoreRules var (Rules rules _) = vcat (map (pprCoreRule (Just var)) rules) +pprCoreRules var (Rules rules _) = vcat (map (pprCoreRule (ppr var)) rules) -pprIfaceCoreRules :: CoreRules -> SDoc -pprIfaceCoreRules (Rules rules _) = vcat (map (pprCoreRule Nothing) rules) - -pprCoreRule :: Maybe Id -> CoreRule -> SDoc -pprCoreRule maybe_fn (BuiltinRule _) +pprCoreRule :: SDoc -> CoreRule -> SDoc +pprCoreRule pp_fn (BuiltinRule _) = ifPprDebug (ptext SLIT("A built in rule")) -pprCoreRule maybe_fn (Rule name tpl_vars tpl_args rhs) +pprCoreRule pp_fn (Rule name tpl_vars tpl_args rhs) = doubleQuotes (ptext name) <+> sep [ ptext SLIT("__forall") <+> braces (sep (map pprTypedBinder tpl_vars)), - nest 4 (pp_fn <+> sep (map pprIfaceArg tpl_args)), - nest 4 (ptext SLIT("=") <+> pprIfaceUnfolding rhs) + nest 4 (pp_fn <+> sep (map pprArg tpl_args)), + nest 4 (ptext SLIT("=") <+> pprCoreExpr rhs) ] <+> semi - where - pp_fn = case maybe_fn of - Just id -> ppr id - Nothing -> empty -- Interface file \end{code} diff --git a/ghc/compiler/coreSyn/Subst.lhs b/ghc/compiler/coreSyn/Subst.lhs index 62b33c6375..1f4c3b8495 100644 --- a/ghc/compiler/coreSyn/Subst.lhs +++ b/ghc/compiler/coreSyn/Subst.lhs @@ -35,7 +35,7 @@ import CoreSyn ( Expr(..), Bind(..), Note(..), CoreExpr, CoreBndr, CoreRules(..), CoreRule(..), emptyCoreRules, isEmptyCoreRules, seqRules ) -import CoreFVs ( exprFreeVars ) +import CoreFVs ( exprFreeVars, mustHaveLocalBinding ) import TypeRep ( Type(..), TyNote(..), ) -- friend import Type ( ThetaType, PredType(..), ClassContext, @@ -45,7 +45,6 @@ import VarSet import VarEnv import Var ( setVarUnique, isId ) import Id ( idType, setIdType, idOccInfo, zapFragileIdInfo ) -import Name ( isLocallyDefined ) import IdInfo ( IdInfo, isFragileOccInfo, specInfo, setSpecInfo, WorkerInfo(..), workerExists, workerInfo, setWorkerInfo, WorkerInfo @@ -189,7 +188,8 @@ lookupInScope in_scope v = case lookupVarEnv in_scope v of Just v' | v == v' -> v' -- Reached a fixed point | otherwise -> lookupInScope in_scope v' - Nothing -> v + Nothing -> WARN( mustHaveLocalBinding v, ppr v ) + v isInScope :: Var -> Subst -> Bool isInScope v (Subst in_scope _) = v `elemVarEnv` in_scope diff --git a/ghc/compiler/deSugar/Check.lhs b/ghc/compiler/deSugar/Check.lhs index 821332a481..45a1ad8fcd 100644 --- a/ghc/compiler/deSugar/Check.lhs +++ b/ghc/compiler/deSugar/Check.lhs @@ -22,19 +22,18 @@ import DsUtils ( EquationInfo(..), tidyLitPat ) import Id ( idType ) -import DataCon ( DataCon, isTupleCon, isUnboxedTupleCon, dataConArgTys, +import DataCon ( DataCon, dataConTyCon, dataConArgTys, dataConSourceArity, dataConFieldLabels ) import Name ( Name, mkLocalName, getOccName, isDataSymOcc, getName, mkSrcVarOcc ) import Type ( Type, splitAlgTyConApp, mkTyVarTys, - isUnboxedType, splitTyConApp_maybe + splitTyConApp_maybe ) import TysWiredIn ( nilDataCon, consDataCon, - mkListTy, - mkTupleTy, tupleCon, - mkUnboxedTupleTy, unboxedTupleCon + mkListTy, mkTupleTy, tupleCon ) import Unique ( unboundKey ) -import TyCon ( tyConDataCons ) +import TyCon ( tyConDataCons, tupleTyConBoxity, isTupleTyCon ) +import BasicTypes ( Boxity(..) ) import SrcLoc ( noSrcLoc ) import UniqSet import Outputable @@ -538,13 +537,13 @@ make_con (ConPat id _ _ _ _) (p:q:ps, constraints) fixity = panic "Check.make_con: Guessing fixity" make_con (ConPat id _ _ _ pats) (ps,constraints) - | isTupleCon id = (TuplePatIn pats_con True : rest_pats, constraints) - | isUnboxedTupleCon id = (TuplePatIn pats_con False : rest_pats, constraints) - | otherwise = (ConPatIn name pats_con : rest_pats, constraints) + | isTupleTyCon tc = (TuplePatIn pats_con (tupleTyConBoxity tc) : rest_pats, constraints) + | otherwise = (ConPatIn name pats_con : rest_pats, constraints) where num_args = length pats name = getName id pats_con = take num_args ps rest_pats = drop num_args ps + tc = dataConTyCon id make_whole_con :: DataCon -> WarningPat @@ -591,15 +590,9 @@ simplify_pat (ListPat ty ps) = foldr (\ x -> \y -> ConPat consDataCon list_ty [] where list_ty = mkListTy ty -simplify_pat (TuplePat ps True) = ConPat (tupleCon arity) - (mkTupleTy arity (map outPatType ps)) [] [] - (map simplify_pat ps) - where - arity = length ps - -simplify_pat (TuplePat ps False) - = ConPat (unboxedTupleCon arity) - (mkUnboxedTupleTy arity (map outPatType ps)) [] [] +simplify_pat (TuplePat ps boxity) + = ConPat (tupleCon boxity arity) + (mkTupleTy boxity arity (map outPatType ps)) [] [] (map simplify_pat ps) where arity = length ps @@ -641,9 +634,9 @@ simplify_pat (NPlusKPat id hslit ty hsexpr1 hsexpr2) = simplify_pat (DictPat dicts methods) = case num_of_d_and_ms of - 0 -> simplify_pat (TuplePat [] True) + 0 -> simplify_pat (TuplePat [] Boxed) 1 -> simplify_pat (head dict_and_method_pats) - _ -> simplify_pat (TuplePat dict_and_method_pats True) + _ -> simplify_pat (TuplePat dict_and_method_pats Boxed) where num_of_d_and_ms = length dicts + length methods dict_and_method_pats = map VarPat (dicts ++ methods) diff --git a/ghc/compiler/deSugar/Desugar.lhs b/ghc/compiler/deSugar/Desugar.lhs index 2aa24b73f6..a870cd433c 100644 --- a/ghc/compiler/deSugar/Desugar.lhs +++ b/ghc/compiler/deSugar/Desugar.lhs @@ -10,7 +10,6 @@ module Desugar ( deSugar ) where import CmdLineOpts ( opt_D_dump_ds ) import HsSyn ( MonoBinds, RuleDecl(..), RuleBndr(..), HsExpr(..), HsBinds(..), MonoBinds(..) ) -import HsCore ( UfRuleBody(..) ) import TcHsSyn ( TypecheckedMonoBinds, TypecheckedForeignDecl, TypecheckedRuleDecl ) import TcModule ( TcResults(..) ) import CoreSyn @@ -77,11 +76,12 @@ deSugar mod_name us (TcResults {tc_env = global_val_env, dsProgram mod_name all_binds rules fo_decls = dsMonoBinds auto_scc all_binds [] `thenDs` \ core_prs -> dsForeigns mod_name fo_decls `thenDs` \ (fi_binds, fe_binds, h_code, c_code) -> - mapDs dsRule rules `thenDs` \ rules' -> - let - ds_binds = fi_binds ++ [Rec core_prs] ++ fe_binds - fe_binders = bindersOfBinds fe_binds + let + ds_binds = fi_binds ++ [Rec core_prs] ++ fe_binds + fe_binders = bindersOfBinds fe_binds + local_binders = mkVarSet (bindersOfBinds ds_binds) in + mapDs (dsRule local_binders) rules `thenDs` \ rules' -> returnDs (ds_binds, rules', h_code, c_code, fe_binders) where auto_scc | opt_SccProfilingOn = TopLevel @@ -101,19 +101,19 @@ ppr_ds_rules rules %************************************************************************ \begin{code} -dsRule :: TypecheckedRuleDecl -> DsM ProtoCoreRule -dsRule (IfaceRuleDecl fn (CoreRuleBody name all_vars args rhs) loc) - = returnDs (ProtoCoreRule False {- non-local -} fn - (Rule name all_vars args rhs)) +dsRule :: IdSet -> TypecheckedRuleDecl -> DsM ProtoCoreRule +dsRule in_scope (IfaceRuleOut fn rule) + = returnDs (ProtoCoreRule False {- non-local -} fn rule) -dsRule (RuleDecl name sig_tvs vars lhs rhs loc) +dsRule in_scope (HsRule name sig_tvs vars lhs rhs loc) = putSrcLocDs loc $ ds_lhs all_vars lhs `thenDs` \ (fn, args) -> dsExpr rhs `thenDs` \ core_rhs -> returnDs (ProtoCoreRule True {- local -} fn - (Rule name all_vars args core_rhs)) + (Rule name tpl_vars args core_rhs)) where - all_vars = sig_tvs ++ [var | RuleBndr var <- vars] + tpl_vars = sig_tvs ++ [var | RuleBndr var <- vars] + all_vars = in_scope `unionVarSet` mkVarSet tpl_vars ds_lhs all_vars lhs = let @@ -132,7 +132,7 @@ ds_lhs all_vars lhs -- Note recursion here... substitution won't terminate -- if there is genuine recursion... which there isn't - subst = mkSubst (mkVarSet all_vars) subst_env + subst = mkSubst all_vars subst_env body'' = substExpr subst body' in diff --git a/ghc/compiler/deSugar/DsCCall.lhs b/ghc/compiler/deSugar/DsCCall.lhs index 11ca5a093a..6d488c44e7 100644 --- a/ghc/compiler/deSugar/DsCCall.lhs +++ b/ghc/compiler/deSugar/DsCCall.lhs @@ -28,7 +28,7 @@ import DataCon ( DataCon, splitProductType_maybe, dataConSourceArity, dataConWr import CallConv import Type ( isUnLiftedType, splitAlgTyConApp_maybe, mkFunTys, splitTyConApp_maybe, tyVarsOfType, mkForAllTys, - isNewType, repType, isUnLiftedType, mkFunTy, + isNewType, repType, isUnLiftedType, mkFunTy, mkTyConApp, Type ) import PprType ( {- instance Outputable Type -} ) @@ -36,14 +36,15 @@ import TysPrim ( byteArrayPrimTy, realWorldStatePrimTy, byteArrayPrimTyCon, mutableByteArrayPrimTyCon, intPrimTy ) import TysWiredIn ( unitDataConId, stringTy, - unboxedPairDataCon, - mkUnboxedTupleTy, unboxedTupleCon, + unboxedSingletonDataCon, unboxedPairDataCon, + unboxedSingletonTyCon, unboxedPairTyCon, + mkTupleTy, tupleCon, boolTy, trueDataCon, falseDataCon, trueDataConId, falseDataConId, unitTy ) import Literal ( mkMachInt ) import CStrings ( CLabelString ) -import Unique ( Unique, Uniquable(..), ioTyConKey ) +import Unique ( Unique, Uniquable(..), hasKey, ioTyConKey ) import VarSet ( varSetElems ) import Outputable \end{code} @@ -212,7 +213,7 @@ boxResult result_ty = case splitAlgTyConApp_maybe result_ty of -- The result is IO t, so wrap the result in an IO constructor - Just (io_tycon, [io_res_ty], [io_data_con]) | getUnique io_tycon == ioTyConKey + Just (io_tycon, [io_res_ty], [io_data_con]) | io_tycon `hasKey` ioTyConKey -> mk_alt return_result (resultWrapper io_res_ty) `thenDs` \ (ccall_res_ty, the_alt) -> newSysLocalDs realWorldStatePrimTy `thenDs` \ state_id -> @@ -247,8 +248,8 @@ boxResult result_ty newSysLocalDs realWorldStatePrimTy `thenDs` \ state_id -> let the_rhs = return_result (Var state_id) (wrap_result (panic "boxResult")) - ccall_res_ty = mkUnboxedTupleTy 1 [realWorldStatePrimTy] - the_alt = (DataAlt (unboxedTupleCon 1), [state_id], the_rhs) + ccall_res_ty = mkTyConApp unboxedSingletonTyCon [realWorldStatePrimTy] + the_alt = (DataAlt unboxedSingletonDataCon, [state_id], the_rhs) in returnDs (ccall_res_ty, the_alt) @@ -258,7 +259,7 @@ boxResult result_ty newSysLocalDs prim_res_ty `thenDs` \ result_id -> let the_rhs = return_result (Var state_id) (wrap_result (Var result_id)) - ccall_res_ty = mkUnboxedTupleTy 2 [realWorldStatePrimTy, prim_res_ty] + ccall_res_ty = mkTyConApp unboxedPairTyCon [realWorldStatePrimTy, prim_res_ty] the_alt = (DataAlt unboxedPairDataCon, [state_id, result_id], the_rhs) in returnDs (ccall_res_ty, the_alt) diff --git a/ghc/compiler/deSugar/DsExpr.lhs b/ghc/compiler/deSugar/DsExpr.lhs index 5eefa471ab..94149c29c4 100644 --- a/ghc/compiler/deSugar/DsExpr.lhs +++ b/ghc/compiler/deSugar/DsExpr.lhs @@ -26,14 +26,16 @@ import DsBinds ( dsMonoBinds, AutoScc(..) ) import DsGRHSs ( dsGuarded ) import DsCCall ( dsCCall, resultWrapper ) import DsListComp ( dsListComp ) -import DsUtils ( mkErrorAppDs, mkDsLets, mkConsExpr, mkNilExpr ) +import DsUtils ( mkErrorAppDs, mkDsLets, mkStringLit, mkStringLitFS, + mkConsExpr, mkNilExpr + ) import Match ( matchWrapper, matchSimply ) import CostCentre ( mkUserCC ) import FieldLabel ( FieldLabel ) import Id ( Id, idType, recordSelectorFieldLabel ) +import PrelInfo ( rEC_CON_ERROR_ID, rEC_UPD_ERROR_ID, iRREFUT_PAT_ERROR_ID ) import DataCon ( DataCon, dataConWrapId, dataConTyCon, dataConArgTys, dataConFieldLabels ) -import PrelInfo ( rEC_CON_ERROR_ID, rEC_UPD_ERROR_ID, iRREFUT_PAT_ERROR_ID, addr2IntegerId ) import TyCon ( isNewTyCon ) import DataCon ( isExistentialDataCon ) import Literal ( Literal(..), inIntRange ) @@ -42,14 +44,14 @@ import Type ( splitFunTys, mkTyConApp, isNotUsgTy, unUsgTy, splitAppTy, isUnLiftedType, Type ) -import TysWiredIn ( tupleCon, unboxedTupleCon, +import TysWiredIn ( tupleCon, listTyCon, mkListTy, charDataCon, charTy, stringTy, smallIntegerDataCon, isIntegerTy ) -import BasicTypes ( RecFlag(..) ) +import BasicTypes ( RecFlag(..), Boxity(..) ) import Maybes ( maybeToBool ) -import Unique ( Uniquable(..), ratioTyConKey ) +import Unique ( Uniquable(..), hasKey, ratioTyConKey, addr2IntegerIdKey ) import Util ( zipEqual, zipWithEqual ) import Outputable @@ -160,7 +162,7 @@ dsExpr (HsLitOut (HsString s) _) -- "_" => build (\ c n -> c 'c' n) -- LATER dsExpr (HsLitOut (HsString str) _) - = returnDs (mkStringLitFS str) + = mkStringLitFS str dsExpr (HsLitOut (HsLitLit str) ty) = ASSERT( maybeToBool maybe_ty ) @@ -170,24 +172,23 @@ dsExpr (HsLitOut (HsLitLit str) ty) Just rep_ty = maybe_ty dsExpr (HsLitOut (HsInt i) ty) - = returnDs (mkIntegerLit i) + = mkIntegerLit i dsExpr (HsLitOut (HsFrac r) ty) - = returnDs (mkConApp ratio_data_con [Type integer_ty, - mkIntegerLit (numerator r), - mkIntegerLit (denominator r)]) + = mkIntegerLit (numerator r) `thenDs` \ num -> + mkIntegerLit (denominator r) `thenDs` \ denom -> + returnDs (mkConApp ratio_data_con [Type integer_ty, num, denom]) where (ratio_data_con, integer_ty) = case (splitAlgTyConApp_maybe ty) of Just (tycon, [i_ty], [con]) - -> ASSERT(isIntegerTy i_ty && getUnique tycon == ratioTyConKey) + -> ASSERT(isIntegerTy i_ty && tycon `hasKey` ratioTyConKey) (con, i_ty) _ -> (panic "ratio_data_con", panic "integer_ty") - -- others where we know what to do: dsExpr (HsLitOut (HsIntPrim i) _) @@ -300,7 +301,7 @@ dsExpr (HsCase discrim matches src_loc) returnDs (Case core_discrim bndr alts) _ -> panic ("dsExpr: tuple pattern:\n" ++ showSDoc (ppr matching_code)) where - ubx_tuple_match (Match _ [TuplePat ps False{-unboxed-}] _ _) = True + ubx_tuple_match (Match _ [TuplePat ps Unboxed] _ _) = True ubx_tuple_match _ = False dsExpr (HsCase discrim matches src_loc) @@ -379,12 +380,10 @@ dsExpr (ExplicitListOut ty xs) ASSERT( isNotUsgTy ty ) returnDs (mkConsExpr ty core_x core_xs) -dsExpr (ExplicitTuple expr_list boxed) +dsExpr (ExplicitTuple expr_list boxity) = mapDs dsExpr expr_list `thenDs` \ core_exprs -> - returnDs (mkConApp ((if boxed - then tupleCon - else unboxedTupleCon) (length expr_list)) - (map (Type . unUsgTy . exprType) core_exprs ++ core_exprs)) + returnDs (mkConApp (tupleCon boxity (length expr_list)) + (map (Type . unUsgTy . exprType) core_exprs ++ core_exprs)) -- the above unUsgTy is *required* -- KSW 1999-04-07 dsExpr (ArithSeqOut expr (From from)) @@ -592,12 +591,14 @@ dsDo do_or_lc stmts return_id then_id fail_id result_ty = do_expr expr locn `thenDs` \ expr2 -> go stmts `thenDs` \ rest -> let msg = ASSERT( isNotUsgTy b_ty ) - "Pattern match failure in do expression, " ++ showSDoc (ppr locn) in + "Pattern match failure in do expression, " ++ showSDoc (ppr locn) + in + mkStringLit msg `thenDs` \ core_msg -> returnDs (mkIfThenElse expr2 rest (App (App (Var fail_id) (Type b_ty)) - (mkStringLit msg))) + core_msg)) go (ExprStmt expr locn : stmts) = do_expr expr locn `thenDs` \ expr2 -> @@ -659,12 +660,13 @@ var_pat _ = False \end{code} \begin{code} -mkIntegerLit :: Integer -> CoreExpr +mkIntegerLit :: Integer -> DsM CoreExpr mkIntegerLit i | inIntRange i -- Small enough, so start from an Int - = mkConApp smallIntegerDataCon [mkIntLit i] + = returnDs (mkConApp smallIntegerDataCon [mkIntLit i]) | otherwise -- Big, so start from a string - = App (Var addr2IntegerId) (Lit (MachStr (_PK_ (show i)))) + = dsLookupGlobalValue addr2IntegerIdKey `thenDs` \ addr2IntegerId -> + returnDs (App (Var addr2IntegerId) (Lit (MachStr (_PK_ (show i))))) \end{code} diff --git a/ghc/compiler/deSugar/DsForeign.lhs b/ghc/compiler/deSugar/DsForeign.lhs index c501beb358..d2c20a3267 100644 --- a/ghc/compiler/deSugar/DsForeign.lhs +++ b/ghc/compiler/deSugar/DsForeign.lhs @@ -30,7 +30,6 @@ import Name ( mkGlobalName, nameModule, nameOccName, getOccString, mkForeignExportOcc, isLocalName, NamedThing(..), Provenance(..), ExportFlag(..) ) -import PrelInfo ( deRefStablePtr_NAME, returnIO_NAME, bindIO_NAME, makeStablePtr_NAME ) import Type ( unUsgTy, splitTyConApp_maybe, splitFunTys, splitForAllTys, Type, mkFunTys, mkForAllTys, mkTyConApp, @@ -41,9 +40,12 @@ import PrimOp ( PrimOp(..), CCall(..), CCallTarget(..) ) import Var ( TyVar ) import TysPrim ( realWorldStatePrimTy, addrPrimTy ) import TysWiredIn ( unitTy, addrTy, stablePtrTyCon, - unboxedTupleCon, addrDataCon + addrDataCon ) -import Unique +import Unique ( Uniquable(..), hasKey, + ioTyConKey, deRefStablePtrIdKey, returnIOIdKey, + bindIOIdKey, makeStablePtrIdKey + ) import Maybes ( maybeToBool ) import Outputable \end{code} @@ -201,12 +203,12 @@ dsFExport fn_id ty mod_name ext_name cconv isDyn -- If it's plain t, return (\x.returnIO x, IO t, t) (case splitTyConApp_maybe orig_res_ty of Just (ioTyCon, [res_ty]) - -> ASSERT( getUnique ioTyCon == ioTyConKey ) + -> ASSERT( ioTyCon `hasKey` ioTyConKey ) -- The function already returns IO t returnDs (\body -> body, orig_res_ty, res_ty) other -> -- The function returns t, so wrap the call in returnIO - dsLookupGlobalValue returnIO_NAME `thenDs` \ retIOId -> + dsLookupGlobalValue returnIOIdKey `thenDs` \ retIOId -> returnDs (\body -> mkApps (Var retIOId) [Type orig_res_ty, body], funResultTy (applyTy (idType retIOId) orig_res_ty), -- We don't have ioTyCon conveniently to hand @@ -221,13 +223,12 @@ dsFExport fn_id ty mod_name ext_name cconv isDyn (if isDyn then newSysLocalDs stbl_ptr_ty `thenDs` \ stbl_ptr -> newSysLocalDs stbl_ptr_to_ty `thenDs` \ stbl_value -> - dsLookupGlobalValue deRefStablePtr_NAME `thenDs` \ deRefStablePtrId -> + dsLookupGlobalValue deRefStablePtrIdKey `thenDs` \ deRefStablePtrId -> + dsLookupGlobalValue bindIOIdKey `thenDs` \ bindIOId -> let the_deref_app = mkApps (Var deRefStablePtrId) [ Type stbl_ptr_to_ty, Var stbl_ptr ] - in - dsLookupGlobalValue bindIO_NAME `thenDs` \ bindIOId -> - let + stbl_app cont = mkApps (Var bindIOId) [ Type stbl_ptr_to_ty , Type res_ty @@ -338,11 +339,11 @@ dsFExportDynamic i ty mod_name ext_name cconv = dsFExport i export_ty mod_name fe_ext_name cconv True `thenDs` \ (fe@(NonRec fe_helper fe_expr), h_code, c_code) -> newSysLocalDs arg_ty `thenDs` \ cback -> - dsLookupGlobalValue makeStablePtr_NAME `thenDs` \ makeStablePtrId -> + dsLookupGlobalValue makeStablePtrIdKey `thenDs` \ makeStablePtrId -> let mk_stbl_ptr_app = mkApps (Var makeStablePtrId) [ Type arg_ty, Var cback ] in - dsLookupGlobalValue bindIO_NAME `thenDs` \ bindIOId -> + dsLookupGlobalValue bindIOIdKey `thenDs` \ bindIOId -> newSysLocalDs (mkTyConApp stablePtrTyCon [arg_ty]) `thenDs` \ stbl_value -> let stbl_app cont ret_ty diff --git a/ghc/compiler/deSugar/DsGRHSs.lhs b/ghc/compiler/deSugar/DsGRHSs.lhs index e5b823b32d..e413c58e81 100644 --- a/ghc/compiler/deSugar/DsGRHSs.lhs +++ b/ghc/compiler/deSugar/DsGRHSs.lhs @@ -19,7 +19,7 @@ import Type ( Type ) import DsMonad import DsUtils import PrelInfo ( nON_EXHAUSTIVE_GUARDS_ERROR_ID ) -import Unique ( otherwiseIdKey, trueDataConKey, Uniquable(..) ) +import Unique ( otherwiseIdKey, trueDataConKey, hasKey, Uniquable(..) ) import Outputable \end{code} @@ -81,11 +81,9 @@ matchGuard (ExprStmt expr locn : should_be_null) ctx -- Turn an "otherwise" guard is a no-op matchGuard (GuardStmt (HsVar v) _ : stmts) ctx - | uniq == otherwiseIdKey - || uniq == trueDataConKey + | v `hasKey` otherwiseIdKey + || v `hasKey` trueDataConKey = matchGuard stmts ctx - where - uniq = getUnique v matchGuard (GuardStmt expr locn : stmts) ctx = matchGuard stmts ctx `thenDs` \ match_result -> @@ -107,4 +105,4 @@ Should {\em fail} if @e@ returns @D@ \begin{verbatim} f x | p <- e', let C y# = e, f y# = r1 | otherwise = r2 -\end{verbatim}
\ No newline at end of file +\end{verbatim} diff --git a/ghc/compiler/deSugar/DsHsSyn.lhs b/ghc/compiler/deSugar/DsHsSyn.lhs index 5149297bcb..f7c78f04fb 100644 --- a/ghc/compiler/deSugar/DsHsSyn.lhs +++ b/ghc/compiler/deSugar/DsHsSyn.lhs @@ -14,7 +14,8 @@ import TcHsSyn ( TypecheckedPat, import Id ( idType, Id ) import Type ( Type ) -import TysWiredIn ( mkListTy, mkTupleTy, mkUnboxedTupleTy, unitTy ) +import TysWiredIn ( mkListTy, mkTupleTy, unitTy ) +import BasicTypes ( Boxity(..) ) import Panic ( panic ) \end{code} @@ -29,8 +30,7 @@ outPatType (LazyPat pat) = outPatType pat outPatType (AsPat var pat) = idType var outPatType (ConPat _ ty _ _ _) = ty outPatType (ListPat ty _) = mkListTy ty -outPatType (TuplePat pats True) = mkTupleTy (length pats) (map outPatType pats) -outPatType (TuplePat pats False)= mkUnboxedTupleTy (length pats) (map outPatType pats) +outPatType (TuplePat pats box) = mkTupleTy box (length pats) (map outPatType pats) outPatType (RecPat _ ty _ _ _) = ty outPatType (LitPat lit ty) = ty outPatType (NPat lit ty _) = ty @@ -38,7 +38,7 @@ outPatType (NPlusKPat _ _ ty _ _) = ty outPatType (DictPat ds ms) = case (length ds_ms) of 0 -> unitTy 1 -> idType (head ds_ms) - n -> mkTupleTy n (map idType ds_ms) + n -> mkTupleTy Boxed n (map idType ds_ms) where ds_ms = ds ++ ms \end{code} diff --git a/ghc/compiler/deSugar/DsListComp.lhs b/ghc/compiler/deSugar/DsListComp.lhs index df05dd428c..8b79313f95 100644 --- a/ghc/compiler/deSugar/DsListComp.lhs +++ b/ghc/compiler/deSugar/DsListComp.lhs @@ -22,11 +22,11 @@ import CmdLineOpts ( opt_FoldrBuildOn ) import CoreUtils ( exprType, mkIfThenElse ) import Id ( idType ) import Var ( Id, TyVar ) -import PrelInfo ( foldrId, buildId ) import Type ( mkTyVarTy, mkForAllTy, mkFunTys, mkFunTy, Type ) import TysPrim ( alphaTyVar, alphaTy ) import TysWiredIn ( nilDataCon, consDataCon, listTyCon ) import Match ( matchSimply ) +import Unique ( foldrIdKey, buildIdKey ) import Outputable \end{code} @@ -51,12 +51,13 @@ dsListComp quals elt_ty n_ty = mkTyVarTy n_tyvar c_ty = mkFunTys [elt_ty, n_ty] n_ty in - newSysLocalsDs [c_ty,n_ty] `thenDs` \ [c, n] -> + newSysLocalsDs [c_ty,n_ty] `thenDs` \ [c, n] -> - dfListComp c n quals `thenDs` \ result -> + dfListComp c n quals `thenDs` \ result -> - returnDs (Var buildId `App` Type elt_ty - `App` mkLams [n_tyvar, c, n] result) + dsLookupGlobalValue buildIdKey `thenDs` \ build_id -> + returnDs (Var build_id `App` Type elt_ty + `App` mkLams [n_tyvar, c, n] result) \end{code} %************************************************************************ @@ -207,12 +208,13 @@ dfListComp c_id n_id (BindStmt pat list1 locn : quals) matchSimply (Var x) ListCompMatch pat core_rest (Var b) `thenDs` \ core_expr -> -- now build the outermost foldr, and return + dsLookupGlobalValue foldrIdKey `thenDs` \ foldr_id -> returnDs ( - Var foldrId `App` Type x_ty - `App` Type b_ty - `App` mkLams [x, b] core_expr - `App` Var n_id - `App` core_list1 + Var foldr_id `App` Type x_ty + `App` Type b_ty + `App` mkLams [x, b] core_expr + `App` Var n_id + `App` core_list1 ) \end{code} diff --git a/ghc/compiler/deSugar/DsMonad.lhs b/ghc/compiler/deSugar/DsMonad.lhs index b11166ac54..ae58ca9eb6 100644 --- a/ghc/compiler/deSugar/DsMonad.lhs +++ b/ghc/compiler/deSugar/DsMonad.lhs @@ -41,7 +41,7 @@ import Type ( Type ) import UniqSupply ( initUs_, splitUniqSupply, uniqFromSupply, uniqsFromSupply, UniqSM, UniqSupply ) import Unique ( Unique ) -import UniqFM ( lookupWithDefaultUFM ) +import UniqFM ( lookupWithDefaultUFM_Directly ) import Util ( zipWithEqual ) infixr 9 `thenDs` @@ -201,13 +201,11 @@ getModuleDs us genv loc mod warns = (mod, warns) \end{code} \begin{code} -dsLookupGlobalValue :: Name -> DsM Id -dsLookupGlobalValue name us genv loc mod warns - = case maybeWiredInIdName name of - Just id -> (id, warns) - Nothing -> (lookupWithDefaultUFM genv def name, warns) +dsLookupGlobalValue :: Unique -> DsM Id +dsLookupGlobalValue key us genv loc mod warns + = (lookupWithDefaultUFM_Directly genv def key, warns) where - def = pprPanic "tcLookupGlobalValue:" (ppr name) + def = pprPanic "tcLookupGlobalValue:" (ppr key) \end{code} diff --git a/ghc/compiler/deSugar/DsUtils.lhs b/ghc/compiler/deSugar/DsUtils.lhs index 181beeb3dd..cdd1fd3b3a 100644 --- a/ghc/compiler/deSugar/DsUtils.lhs +++ b/ghc/compiler/deSugar/DsUtils.lhs @@ -21,6 +21,7 @@ module DsUtils ( mkCoPrimCaseMatchResult, mkCoAlgCaseMatchResult, mkErrorAppDs, mkNilExpr, mkConsExpr, + mkStringLit, mkStringLitFS, mkSelectorBinds, mkTupleExpr, mkTupleSelector, @@ -41,7 +42,7 @@ import DsMonad import CoreUtils ( exprType, mkIfThenElse ) import PrelInfo ( iRREFUT_PAT_ERROR_ID ) import Id ( idType, Id, mkWildId ) -import Literal ( Literal ) +import Literal ( Literal(..) ) import TyCon ( isNewTyCon, tyConDataCons ) import DataCon ( DataCon, StrictnessMark, maybeMarkedUnboxed, dataConStrictMarks, dataConId, splitProductType_maybe @@ -67,7 +68,9 @@ import TysWiredIn ( nilDataCon, consDataCon, addrTy, addrDataCon, wordTy, wordDataCon ) +import BasicTypes ( Boxity(..) ) import UniqSet ( mkUniqSet, minusUniqSet, isEmptyUniqSet, UniqSet ) +import Unique ( unpackCStringIdKey, unpackCString2IdKey ) import Outputable \end{code} @@ -376,8 +379,29 @@ mkErrorAppDs err_id ty msg let full_msg = showSDoc (hcat [ppr src_loc, text "|", text msg]) in - returnDs (mkApps (Var err_id) [(Type . unUsgTy) ty, mkStringLit full_msg]) + mkStringLit full_msg `thenDs` \ core_msg -> + returnDs (mkApps (Var err_id) [(Type . unUsgTy) ty, core_msg]) -- unUsgTy *required* -- KSW 1999-04-07 + +mkStringLit :: String -> DsM CoreExpr +mkStringLit str = mkStringLitFS (_PK_ str) + +mkStringLitFS :: FAST_STRING -> DsM CoreExpr +mkStringLitFS str + | any is_NUL (_UNPK_ str) + = -- Must cater for NULs in literal string + dsLookupGlobalValue unpackCString2IdKey `thenDs` \ unpack_id -> + returnDs (mkApps (Var unpack_id) + [Lit (MachStr str), + mkIntLitInt (_LENGTH_ str)]) + + | otherwise + = -- No NULs in the string + dsLookupGlobalValue unpackCStringIdKey `thenDs` \ unpack_id -> + returnDs (App (Var unpack_id) (Lit (MachStr str))) + + where + is_NUL c = c == '\0' \end{code} %************************************************************************ @@ -421,9 +445,10 @@ mkSelectorBinds pat val_expr let full_msg = showSDoc (hcat [ppr src_loc, text "|", ppr pat]) in + mkStringLit full_msg `thenDs` \ core_msg -> mapDs (mk_bind val_var msg_var) binders `thenDs` \ binds -> returnDs ( (val_var, val_expr) : - (msg_var, mkStringLit full_msg) : + (msg_var, core_msg) : binds ) @@ -455,7 +480,7 @@ mkSelectorBinds pat val_expr binder_ty = idType bndr_var error_expr = mkApps (Var iRREFUT_PAT_ERROR_ID) [Type binder_ty, Var msg_var] - is_simple_pat (TuplePat ps True{-boxed-}) = all is_triv_pat ps + is_simple_pat (TuplePat ps Boxed) = all is_triv_pat ps is_simple_pat (ConPat _ _ _ _ ps) = all is_triv_pat ps is_simple_pat (VarPat _) = True is_simple_pat (RecPat _ _ _ _ ps) = and [is_triv_pat p | (_,p,_) <- ps] @@ -476,7 +501,7 @@ mkTupleExpr :: [Id] -> CoreExpr mkTupleExpr [] = Var unitDataConId mkTupleExpr [id] = Var id -mkTupleExpr ids = mkConApp (tupleCon (length ids)) +mkTupleExpr ids = mkConApp (tupleCon Boxed (length ids)) (map (Type . unUsgTy . idType) ids ++ [ Var i | i <- ids ]) \end{code} @@ -503,7 +528,7 @@ mkTupleSelector [var] should_be_the_same_var scrut_var scrut mkTupleSelector vars the_var scrut_var scrut = ASSERT( not (null vars) ) - Case scrut scrut_var [(DataAlt (tupleCon (length vars)), vars, Var the_var)] + Case scrut scrut_var [(DataAlt (tupleCon Boxed (length vars)), vars, Var the_var)] \end{code} diff --git a/ghc/compiler/deSugar/Match.lhs b/ghc/compiler/deSugar/Match.lhs index e69c50adc2..7d0e47fffd 100644 --- a/ghc/compiler/deSugar/Match.lhs +++ b/ghc/compiler/deSugar/Match.lhs @@ -37,9 +37,9 @@ import TysWiredIn ( nilDataCon, consDataCon, mkTupleTy, mkListTy, charTy, charDataCon, intTy, intDataCon, floatTy, floatDataCon, doubleTy, tupleCon, doubleDataCon, addrTy, - addrDataCon, wordTy, wordDataCon, - mkUnboxedTupleTy, unboxedTupleCon + addrDataCon, wordTy, wordDataCon ) +import BasicTypes ( Boxity(..) ) import UniqSet import ErrUtils ( addErrLocHdrLine, dontAddErrLoc ) import Outputable @@ -499,29 +499,20 @@ tidy1 v (ListPat ty pats) match_result (ConPat nilDataCon list_ty [] [] []) pats -tidy1 v (TuplePat pats True{-boxed-}) match_result +tidy1 v (TuplePat pats boxity) match_result = returnDs (tuple_ConPat, match_result) where arity = length pats tuple_ConPat - = ConPat (tupleCon arity) - (mkTupleTy arity (map outPatType pats)) [] [] - pats - -tidy1 v (TuplePat pats False{-unboxed-}) match_result - = returnDs (tuple_ConPat, match_result) - where - arity = length pats - tuple_ConPat - = ConPat (unboxedTupleCon arity) - (mkUnboxedTupleTy arity (map outPatType pats)) [] [] + = ConPat (tupleCon boxity arity) + (mkTupleTy boxity arity (map outPatType pats)) [] [] pats tidy1 v (DictPat dicts methods) match_result = case num_of_d_and_ms of - 0 -> tidy1 v (TuplePat [] True) match_result + 0 -> tidy1 v (TuplePat [] Boxed) match_result 1 -> tidy1 v (head dict_and_method_pats) match_result - _ -> tidy1 v (TuplePat dict_and_method_pats True) match_result + _ -> tidy1 v (TuplePat dict_and_method_pats Boxed) match_result where num_of_d_and_ms = length dicts + length methods dict_and_method_pats = map VarPat (dicts ++ methods) diff --git a/ghc/compiler/hsSyn/HsBinds.lhs b/ghc/compiler/hsSyn/HsBinds.lhs index 4e2f98bcbd..1e7f80bfb5 100644 --- a/ghc/compiler/hsSyn/HsBinds.lhs +++ b/ghc/compiler/hsSyn/HsBinds.lhs @@ -14,7 +14,7 @@ import {-# SOURCE #-} HsExpr ( pprExpr, HsExpr ) import {-# SOURCE #-} HsMatches ( pprMatches, Match, pprGRHSs, GRHSs ) -- friends: -import HsTypes ( HsType, cmpHsType ) +import HsTypes ( HsType ) import HsImpExp ( IE(..), ieName ) import CoreSyn ( CoreExpr ) import PprCore () -- Instances for Outputable @@ -265,16 +265,11 @@ data Sig name | FixSig (FixitySig name) -- Fixity declaration - | DeprecSig (Deprecation name) -- DEPRECATED - SrcLoc - -data FixitySig name = FixitySig name Fixity SrcLoc --- We use exported entities for things to deprecate. Cunning trick (hack?): --- `IEModuleContents undefined' is used for module deprecation. -data Deprecation name = Deprecation (IE name) DeprecTxt +data FixitySig name = FixitySig name Fixity SrcLoc -type DeprecTxt = FAST_STRING -- reason/explanation for deprecation +instance Eq name => Eq (FixitySig name) where + (FixitySig n1 f1 _) == (FixitySig n2 f2 _) = n1==n2 && f1==f2 \end{code} \begin{code} @@ -298,14 +293,6 @@ sigForThisGroup ns sig Just n | isUnboundName n -> True -- Don't complain about an unbound name again | otherwise -> n `elemNameSet` ns -sigsForMe :: (name -> Bool) -> [Sig name] -> [Sig name] -sigsForMe f sigs - = filter sig_for_me sigs - where - sig_for_me sig = case sigName sig of - Nothing -> False - Just n -> f n - sigName :: Sig name -> Maybe name sigName (Sig n _ _) = Just n sigName (ClassOpSig n _ _ _ _) = Just n @@ -313,9 +300,6 @@ sigName (SpecSig n _ _) = Just n sigName (InlineSig n _ _) = Just n sigName (NoInlineSig n _ _) = Just n sigName (FixSig (FixitySig n _ _)) = Just n -sigName (DeprecSig (Deprecation d _) _) = case d of - IEModuleContents _ -> Nothing - other -> Just (ieName d) sigName other = Nothing isFixitySig :: Sig name -> Bool @@ -332,7 +316,6 @@ isPragSig (SpecSig _ _ _) = True isPragSig (InlineSig _ _ _) = True isPragSig (NoInlineSig _ _ _) = True isPragSig (SpecInstSig _ _) = True -isPragSig (DeprecSig _ _) = True isPragSig other = False \end{code} @@ -344,7 +327,6 @@ hsSigDoc (InlineSig _ _ loc) = (SLIT("INLINE pragma"),loc) hsSigDoc (NoInlineSig _ _ loc) = (SLIT("NOINLINE pragma"),loc) hsSigDoc (SpecInstSig _ loc) = (SLIT("SPECIALISE instance pragma"),loc) hsSigDoc (FixSig (FixitySig _ _ loc)) = (SLIT("fixity declaration"), loc) -hsSigDoc (DeprecSig _ loc) = (SLIT("DEPRECATED pragma"), loc) \end{code} \begin{code} @@ -355,8 +337,10 @@ ppr_sig :: Outputable name => Sig name -> SDoc ppr_sig (Sig var ty _) = sep [ppr var <+> dcolon, nest 4 (ppr ty)] -ppr_sig (ClassOpSig var _ _ ty _) - = sep [ppr var <+> dcolon, nest 4 (ppr ty)] +ppr_sig (ClassOpSig var _ dm ty _) + = sep [ppr var <+> pp_dm <+> dcolon, nest 4 (ppr ty)] + where + pp_dm = if dm then equals else empty -- Default-method indicator ppr_sig (SpecSig var ty _) = sep [ hsep [text "{-# SPECIALIZE", ppr var, dcolon], @@ -374,17 +358,10 @@ ppr_sig (SpecInstSig ty _) ppr_sig (FixSig fix_sig) = ppr fix_sig -ppr_sig (DeprecSig deprec _) = ppr deprec instance Outputable name => Outputable (FixitySig name) where ppr (FixitySig name fixity loc) = sep [ppr fixity, ppr name] -instance Outputable name => Outputable (Deprecation name) where - ppr (Deprecation (IEModuleContents _) txt) - = hsep [text "{-# DEPRECATED", doubleQuotes (ppr txt), text "#-}"] - ppr (Deprecation thing txt) - = hsep [text "{-# DEPRECATED", ppr thing, doubleQuotes (ppr txt), text "#-}"] - ppr_phase :: Maybe Int -> SDoc ppr_phase Nothing = empty ppr_phase (Just n) = int n @@ -394,37 +371,16 @@ Checking for distinct signatures; oh, so boring \begin{code} -cmpHsSig :: Sig Name -> Sig Name -> Ordering -cmpHsSig (Sig n1 _ _) (Sig n2 _ _) = n1 `compare` n2 -cmpHsSig (DeprecSig (Deprecation ie1 _) _) - (DeprecSig (Deprecation ie2 _) _) = cmp_ie ie1 ie2 -cmpHsSig (InlineSig n1 _ _) (InlineSig n2 _ _) = n1 `compare` n2 -cmpHsSig (NoInlineSig n1 _ _) (NoInlineSig n2 _ _) = n1 `compare` n2 - -cmpHsSig (SpecInstSig ty1 _) (SpecInstSig ty2 _) = cmpHsType compare ty1 ty2 -cmpHsSig (SpecSig n1 ty1 _) (SpecSig n2 ty2 _) +eqHsSig :: Sig Name -> Sig Name -> Bool +eqHsSig (Sig n1 _ _) (Sig n2 _ _) = n1 == n2 +eqHsSig (InlineSig n1 _ _) (InlineSig n2 _ _) = n1 == n2 +eqHsSig (NoInlineSig n1 _ _) (NoInlineSig n2 _ _) = 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... - thenCmp (n1 `compare` n2) (cmpHsType compare ty1 ty2) - -cmpHsSig other_1 other_2 -- Tags *must* be different - | (sig_tag other_1) _LT_ (sig_tag other_2) = LT - | otherwise = GT - -cmp_ie :: IE Name -> IE Name -> Ordering -cmp_ie (IEVar n1 ) (IEVar n2 ) = n1 `compare` n2 -cmp_ie (IEThingAbs n1 ) (IEThingAbs n2 ) = n1 `compare` n2 -cmp_ie (IEThingAll n1 ) (IEThingAll n2 ) = n1 `compare` n2 --- Hmmm... -cmp_ie (IEThingWith n1 _) (IEThingWith n2 _) = n1 `compare` n2 -cmp_ie (IEModuleContents _ ) (IEModuleContents _ ) = EQ - -sig_tag (Sig n1 _ _) = (ILIT(1) :: FAST_INT) -sig_tag (SpecSig n1 _ _) = ILIT(2) -sig_tag (InlineSig n1 _ _) = ILIT(3) -sig_tag (NoInlineSig n1 _ _) = ILIT(4) -sig_tag (SpecInstSig _ _) = ILIT(5) -sig_tag (FixSig _) = ILIT(6) -sig_tag (DeprecSig _ _) = ILIT(7) -sig_tag _ = panic# "tag(RnBinds)" + (n1 == n2) && (ty1 == ty2) + +eqHsSig other_1 other_2 = False \end{code} diff --git a/ghc/compiler/hsSyn/HsCore.lhs b/ghc/compiler/hsSyn/HsCore.lhs index d7f1317d1f..838bbb38bb 100644 --- a/ghc/compiler/hsSyn/HsCore.lhs +++ b/ghc/compiler/hsSyn/HsCore.lhs @@ -14,25 +14,43 @@ We could either use this, or parameterise @GenCoreExpr@ on @Types@ and module HsCore ( UfExpr(..), UfAlt, UfBinder(..), UfNote(..), UfBinding(..), UfConAlt(..), - HsIdInfo(..), HsStrictnessInfo(..), - IfaceSig(..), UfRuleBody(..) + HsIdInfo(..), + IfaceSig(..), + + eq_ufExpr, eq_ufBinders, pprUfExpr, + + toUfExpr, toUfBndr ) where #include "HsVersions.h" -- friends: -import HsTypes ( HsType, pprParendHsType ) +import HsTypes ( HsType, pprParendHsType, pprHsTyVarBndr, toHsType, + HsTupCon(..), hsTupParens, + emptyEqHsEnv, extendEqHsEnv, eqListBy, + eq_hsType, eq_hsVar, eq_hsVars + ) -- others: -import IdInfo ( ArityInfo, UpdateInfo, InlinePragInfo ) -import CoreSyn ( CoreBndr, CoreExpr ) -import Demand ( Demand ) -import Literal ( Literal ) +import Id ( idArity, idType, isDataConId_maybe, isPrimOpId_maybe ) +import Var ( varType, isId ) +import IdInfo ( ArityInfo, UpdateInfo, InlinePragInfo, + pprInlinePragInfo, ppArityInfo, ppStrictnessInfo + ) +import RdrName ( RdrName ) +import Name ( Name, toRdrName ) +import CoreSyn +import CostCentre ( pprCostCentreCore ) +import PrimOp ( PrimOp(CCallOp) ) +import Demand ( Demand, StrictnessInfo ) +import Literal ( Literal, maybeLitLit ) import PrimOp ( CCall, pprCCallOp ) -import Type ( Kind ) -import PprType ( {- instance Outputable Type -} ) +import DataCon ( dataConTyCon ) +import TyCon ( isTupleTyCon, tupleTyConBoxity ) +import Type ( Type, Kind ) import CostCentre import SrcLoc ( SrcLoc ) +import BasicTypes ( Arity ) import Outputable \end{code} @@ -46,9 +64,9 @@ import Outputable data UfExpr name = UfVar name | UfType (HsType name) - | UfTuple name [UfExpr name] -- Type arguments omitted - | UfLam (UfBinder name) (UfExpr name) - | UfApp (UfExpr name) (UfExpr name) + | UfTuple (HsTupCon name) [UfExpr name] -- Type arguments omitted + | UfLam (UfBinder name) (UfExpr name) + | UfApp (UfExpr name) (UfExpr name) | UfCase (UfExpr name) name [UfAlt name] | UfLet (UfBinding name) (UfExpr name) | UfNote (UfNote name) (UfExpr name) @@ -65,6 +83,7 @@ type UfAlt name = (UfConAlt name, [name], UfExpr name) data UfConAlt name = UfDefault | UfDataAlt name + | UfTupleAlt (HsTupCon name) | UfLitAlt Literal | UfLitLitAlt FAST_STRING (HsType name) @@ -81,54 +100,210 @@ data UfBinder name %************************************************************************ %* * -\subsection[HsCore-print]{Printing Core unfoldings} +\subsection{Converting from Core to UfCore} %* * %************************************************************************ \begin{code} -instance Outputable name => Outputable (UfExpr name) where - ppr (UfVar v) = ppr v - ppr (UfLit l) = ppr l +toUfExpr :: CoreExpr -> UfExpr RdrName +toUfExpr (Var v) = toUfVar v +toUfExpr (Lit l) = case maybeLitLit l of + Just (s,ty) -> UfLitLit s (toHsType ty) + Nothing -> UfLit l +toUfExpr (Type ty) = UfType (toHsType ty) +toUfExpr (Lam x b) = UfLam (toUfBndr x) (toUfExpr b) +toUfExpr (App f a) = toUfApp f [a] +toUfExpr (Case s x as) = UfCase (toUfExpr s) (toRdrName x) (map toUfAlt as) +toUfExpr (Let b e) = UfLet (toUfBind b) (toUfExpr e) +toUfExpr (Note n e) = UfNote (toUfNote n) (toUfExpr e) + +--------------------- +toUfNote (SCC cc) = UfSCC cc +toUfNote (Coerce t1 _) = UfCoerce (toHsType t1) +toUfNote InlineCall = UfInlineCall +toUfNote InlineMe = UfInlineMe + +--------------------- +toUfBind (NonRec b r) = UfNonRec (toUfBndr b) (toUfExpr r) +toUfBind (Rec prs) = UfRec [(toUfBndr b, toUfExpr r) | (b,r) <- prs] + +--------------------- +toUfAlt (c,bs,r) = (toUfCon c, map toRdrName bs, toUfExpr r) + +--------------------- +toUfCon (DataAlt dc) | isTupleTyCon tc = UfTupleAlt (HsTupCon (toRdrName dc) (tupleTyConBoxity tc)) + | otherwise = UfDataAlt (toRdrName dc) + where + tc = dataConTyCon dc + +toUfCon (LitAlt l) = case maybeLitLit l of + Just (s,ty) -> UfLitLitAlt s (toHsType ty) + Nothing -> UfLitAlt l +toUfCon DEFAULT = UfDefault + +--------------------- +toUfBndr x | isId x = UfValBinder (toRdrName x) (toHsType (varType x)) + | otherwise = UfTyBinder (toRdrName x) (varType x) + +--------------------- +toUfApp (App f a) as = toUfApp f (a:as) +toUfApp (Var v) as + = case isDataConId_maybe v of + -- We convert the *worker* for tuples into UfTuples + Just dc | isTupleTyCon tc && saturated -> UfTuple (HsTupCon (toRdrName dc) (tupleTyConBoxity tc)) tup_args + where + val_args = dropWhile isTypeArg as + saturated = length val_args == idArity v + tup_args = map toUfExpr val_args + tc = dataConTyCon dc + ; + + other -> mkUfApps (toUfVar v) as + +toUfApp e as = mkUfApps (toUfExpr e) as + +mkUfApps = foldl (\f a -> UfApp f (toUfExpr a)) + +--------------------- +toUfVar v = case isPrimOpId_maybe v of + -- Ccalls has special syntax + Just (CCallOp cc) -> UfCCall cc (toHsType (idType v)) + other -> UfVar (toRdrName v) +\end{code} - ppr (UfLitLit l ty) = ppr l - ppr (UfCCall cc ty) = pprCCallOp cc - ppr (UfType ty) = char '@' <+> pprParendHsType ty +%************************************************************************ +%* * +\subsection[HsCore-print]{Printing Core unfoldings} +%* * +%************************************************************************ - ppr (UfTuple c as) = parens (hsep (punctuate comma (map ppr as))) +\begin{code} +instance Outputable name => Outputable (UfExpr name) where + ppr e = pprUfExpr noParens e + +noParens :: SDoc -> SDoc +noParens pp = pp + +pprUfExpr :: Outputable name => (SDoc -> SDoc) -> UfExpr name -> SDoc + -- The function adds parens in context that need + -- an atomic value (e.g. function args) + +pprUfExpr add_par (UfVar v) = ppr v +pprUfExpr add_par (UfLit l) = ppr l +pprUfExpr add_par (UfLitLit l ty) = ppr l +pprUfExpr add_par (UfCCall cc ty) = braces (pprCCallOp cc <+> ppr ty) +pprUfExpr add_par (UfType ty) = char '@' <+> pprParendHsType ty +pprUfExpr add_par (UfLam b body) = add_par (hsep [char '\\', ppr b, ptext SLIT("->"), pprUfExpr noParens body]) +pprUfExpr add_par (UfApp fun arg) = add_par (pprUfExpr noParens fun <+> pprUfExpr parens arg) +pprUfExpr add_par (UfTuple c as) = hsTupParens c (interpp'SP as) + +pprUfExpr add_par (UfCase scrut bndr alts) + = add_par (hsep [ptext SLIT("case"), pprUfExpr noParens scrut, ptext SLIT("of"), ppr bndr, + braces (hsep (map pp_alt alts))]) + where + pp_alt (UfTupleAlt tup_con, bs, rhs) = hsTupParens tup_con (interpp'SP bs) <+> ppr_rhs rhs + pp_alt (c, bs, rhs) = ppr c <+> interppSP bs <+> ppr_rhs rhs - ppr (UfLam b body) - = hsep [char '\\', ppr b, ptext SLIT("->"), ppr body] + ppr_rhs rhs = ptext SLIT("->") <+> pprUfExpr noParens rhs <> semi - ppr (UfApp fun arg) = ppr fun <+> ppr arg +pprUfExpr add_par (UfLet (UfNonRec b rhs) body) + = add_par (hsep [ptext SLIT("let"), + braces (ppr b <+> equals <+> pprUfExpr noParens rhs), + ptext SLIT("in"), pprUfExpr noParens body]) - ppr (UfCase scrut bndr alts) - = hsep [ptext SLIT("case"), ppr scrut, ptext SLIT("of"), ppr bndr, - braces (hsep (punctuate semi (map pp_alt alts)))] +pprUfExpr add_par (UfLet (UfRec pairs) body) + = add_par (hsep [ptext SLIT("__letrec"), braces (hsep (map pp_pair pairs)), + ptext SLIT("in"), pprUfExpr noParens body]) where - pp_alt (c,bs,rhs) = hsep [ppr c, ppr bs, ppr_arrow, ppr rhs] - - ppr_arrow = ptext SLIT("->") + pp_pair (b,rhs) = ppr b <+> equals <+> pprUfExpr noParens rhs <> semi - ppr (UfLet (UfNonRec b rhs) body) - = hsep [ptext SLIT("let"), ppr b, equals, ppr rhs, ptext SLIT("in"), ppr body] - ppr (UfLet (UfRec pairs) body) - = hsep [ptext SLIT("letrec"), braces (hsep (punctuate semi (map pp_pair pairs))), ptext SLIT("in"), ppr body] - where - pp_pair (b,rhs) = hsep [ppr b, equals, ppr rhs] +pprUfExpr add_par (UfNote note body) = add_par (ppr note <+> pprUfExpr parens body) - ppr (UfNote note body) - = hsep [ptext SLIT("_NOTE_ [ToDo]>"), ppr body] +instance Outputable name => Outputable (UfNote name) where + ppr (UfSCC cc) = pprCostCentreCore cc + ppr (UfCoerce ty) = ptext SLIT("__coerce") <+> pprParendHsType ty + ppr UfInlineCall = ptext SLIT("__inline_call") + ppr UfInlineMe = ptext SLIT("__inline_me") instance Outputable name => Outputable (UfConAlt name) where - ppr UfDefault = text "DEFAULT" + ppr UfDefault = text "__DEFAULT" ppr (UfLitAlt l) = ppr l ppr (UfLitLitAlt l ty) = ppr l ppr (UfDataAlt d) = ppr d instance Outputable name => Outputable (UfBinder name) where - ppr (UfValBinder name ty) = hsep [ppr name, dcolon, ppr ty] - ppr (UfTyBinder name kind) = hsep [ppr name, dcolon, ppr kind] + ppr (UfValBinder name ty) = hsep [ppr name, dcolon, pprParendHsType ty] + ppr (UfTyBinder name kind) = char '@' <+> pprHsTyVarBndr name kind +\end{code} + + +%************************************************************************ +%* * +\subsection[HsCore-print]{Equality, for interface file checking +%* * +%************************************************************************ + +\begin{code} +instance Ord name => Eq (UfExpr name) where + (==) a b = eq_ufExpr emptyEqHsEnv a b + +----------------- +eq_ufBinder env (UfValBinder n1 t1) (UfValBinder n2 t2) k + = eq_hsType env t1 t2 && k (extendEqHsEnv env n1 n2) +eq_ufBinder env (UfTyBinder n1 k1) (UfTyBinder n2 k2) k + = k1==k2 && k (extendEqHsEnv env n1 n2) +eq_ufBinder _ _ _ _ = False + +----------------- +eq_ufBinders env [] [] k = k env +eq_ufBinders env (b1:bs1) (b2:bs2) k = eq_ufBinder env b1 b2 (\env -> eq_ufBinders env bs1 bs2 k) +eq_ufBinders env _ _ _ = False + +----------------- +eq_ufExpr env (UfVar v1) (UfVar v2) = eq_hsVar env v1 v2 +eq_ufExpr env (UfLit l1) (UfLit l2) = l1 == l2 +eq_ufExpr env (UfLitLit l1 ty1) (UfLitLit l2 ty2) = l1==l2 && eq_hsType env ty1 ty2 +eq_ufExpr env (UfCCall c1 ty1) (UfCCall c2 ty2) = c1==c2 && eq_hsType env ty1 ty2 +eq_ufExpr env (UfType ty1) (UfType ty2) = eq_hsType env ty1 ty2 +eq_ufExpr env (UfTuple n1 as1) (UfTuple n2 as2) = n1==n2 && eqListBy (eq_ufExpr env) as1 as2 +eq_ufExpr env (UfLam b1 body1) (UfLam b2 body2) = eq_ufBinder env b1 b2 (\env -> eq_ufExpr env body1 body2) +eq_ufExpr env (UfApp f1 a1) (UfApp f2 a2) = eq_ufExpr env f1 f2 && eq_ufExpr env a1 a2 + +eq_ufExpr env (UfCase s1 b1 as1) (UfCase s2 b2 as2) + = eq_ufExpr env s1 s2 && + eqListBy (eq_ufAlt (extendEqHsEnv env b1 b2)) as1 as2 + where + eq_ufAlt env (c1,bs1,r1) (c2,bs2,r2) + = eq_ufConAlt env c1 c2 && eq_hsVars env bs1 bs2 (\env -> eq_ufExpr env r1 r2) + +eq_ufExpr env (UfLet (UfNonRec b1 r1) x1) (UfLet (UfNonRec b2 r2) x2) + = eq_ufExpr env r1 r2 && eq_ufBinder env b1 b2 (\env -> eq_ufExpr env x1 x2) + +eq_ufExpr env (UfLet (UfRec as1) x1) (UfLet (UfRec as2) x2) + = eq_ufBinders env bs1 bs2 (\env -> eqListBy (eq_ufExpr env) rs1 rs2 && eq_ufExpr env x1 x2) + where + (bs1,rs1) = unzip as1 + (bs2,rs2) = unzip as2 + +eq_ufExpr env (UfNote n1 r1) (UfNote n2 r2) + = eq_ufNote n1 n2 && eq_ufExpr env r1 r2 + where + eq_ufNote (UfSCC c1) (UfSCC c2) = c1==c2 + eq_ufNote (UfCoerce t1) (UfCoerce t2) = eq_hsType env t1 t2 + eq_ufNote UfInlineCall UfInlineCall = True + eq_ufNote UfInlineMe UfInlineMe = True + eq_ufNote _ _ = False + +eq_ufExpr env _ _ = False + +----------------- +eq_ufConAlt env UfDefault UfDefault = True +eq_ufConAlt env (UfDataAlt n1) (UfDataAlt n2) = n1==n2 +eq_ufConAlt env (UfTupleAlt c1) (UfTupleAlt c2) = c1==c2 +eq_ufConAlt env (UfLitAlt l1) (UfLitAlt l2) = l1==l2 +eq_ufConAlt env (UfLitLitAlt s1 t1) (UfLitLitAlt s2 t2) = s1==s2 && eq_hsType env t1 t2 +eq_ufConAlt env _ _ = False \end{code} @@ -139,44 +314,44 @@ instance Outputable name => Outputable (UfBinder name) where %************************************************************************ \begin{code} -data IfaceSig name - = IfaceSig name - (HsType name) - [HsIdInfo name] - SrcLoc +data IfaceSig name = IfaceSig name (HsType name) [HsIdInfo name] SrcLoc + +instance Ord name => Eq (IfaceSig name) where + (==) (IfaceSig n1 t1 i1 _) (IfaceSig n2 t2 i2 _) = n1==n2 && t1==t2 && i1==i2 instance (Outputable name) => Outputable (IfaceSig name) where - ppr (IfaceSig var ty info _) - = hang (hsep [ppr var, dcolon]) - 4 (ppr ty $$ ifPprDebug (vcat (map ppr info))) + ppr (IfaceSig var ty info _) = hsep [ppr var, dcolon, ppr ty, pprHsIdInfo info] +\end{code} + + +%************************************************************************ +%* * +\subsection{Rules in interface files} +%* * +%************************************************************************ + +\begin{code} +pprHsIdInfo [] = empty +pprHsIdInfo info = ptext SLIT("{-##") <+> hsep (map ppr info) <+> ptext SLIT("##-}") data HsIdInfo name = HsArity ArityInfo - | HsStrictness HsStrictnessInfo + | HsStrictness StrictnessInfo | HsUnfold InlinePragInfo (UfExpr name) | HsUpdate UpdateInfo - | HsSpecialise (UfRuleBody name) | HsNoCafRefs | HsCprInfo | HsWorker name -- Worker, if any + deriving( Eq ) +-- NB: Specialisations and rules come in separately and are +-- only later attached to the Id. Partial reason: some are orphans. instance Outputable name => Outputable (HsIdInfo name) where - ppr (HsUnfold _ unf) = ptext (SLIT("Unfolding:")) <+> ppr unf - ppr other = empty -- Havn't got around to this yet - -data HsStrictnessInfo - = HsStrictnessInfo ([Demand], Bool) - | HsBottom + ppr (HsUnfold prag unf) = ptext SLIT("__U") <> pprInlinePragInfo prag <+> parens (ppr unf) + ppr (HsArity arity) = ppArityInfo arity + ppr (HsStrictness str) = ptext SLIT("__S") <+> ppStrictnessInfo str + ppr HsNoCafRefs = ptext SLIT("__C") + ppr HsCprInfo = ptext SLIT("__M") + ppr (HsWorker w) = ptext SLIT("__P") <+> ppr w \end{code} - -%************************************************************************ -%* * -\subsection{Rules in interface files} -%* * -%************************************************************************ - -\begin{code} -data UfRuleBody name = UfRuleBody FAST_STRING [UfBinder name] [UfExpr name] (UfExpr name) -- Pre typecheck - | CoreRuleBody FAST_STRING [CoreBndr] [CoreExpr] CoreExpr -- Post typecheck -\end{code} diff --git a/ghc/compiler/hsSyn/HsDecls.lhs b/ghc/compiler/hsSyn/HsDecls.lhs index 7f47891852..7fb207ee9a 100644 --- a/ghc/compiler/hsSyn/HsDecls.lhs +++ b/ghc/compiler/hsSyn/HsDecls.lhs @@ -13,27 +13,33 @@ module HsDecls ( ExtName(..), isDynamicExtName, extNameStatic, ConDecl(..), ConDetails(..), BangType(..), IfaceSig(..), SpecDataSig(..), - hsDeclName, tyClDeclName, isClassDecl, isSynDecl, isDataDecl, countTyClDecls + DeprecDecl(..), DeprecTxt, + hsDeclName, tyClDeclName, isClassDecl, isSynDecl, isDataDecl, countTyClDecls, toHsRule ) where #include "HsVersions.h" -- friends: -import HsBinds ( HsBinds, MonoBinds, Sig, FixitySig(..), nullMonoBinds ) +import HsBinds ( HsBinds, MonoBinds, Sig(..), FixitySig(..), nullMonoBinds ) import HsExpr ( HsExpr ) import HsPragmas ( DataPragmas, ClassPragmas ) +import HsImpExp ( IE(..) ) import HsTypes -import HsCore ( UfExpr, UfBinder, IfaceSig(..), UfRuleBody ) +import PprCore ( pprCoreRule ) +import HsCore ( UfExpr(UfVar), UfBinder, IfaceSig(..), eq_ufBinders, eq_ufExpr, pprUfExpr, toUfExpr, toUfBndr ) +import CoreSyn ( CoreRule(..) ) import BasicTypes ( Fixity, NewOrData(..) ) import CallConv ( CallConv, pprCallConv ) -import Var ( TyVar ) +import Var ( TyVar, Id ) +import Name ( toRdrName ) -- others: import PprType -import {-# SOURCE #-} FunDeps ( pprFundeps ) +import FunDeps ( pprFundeps ) +import Class ( FunDep ) import CStrings ( CLabelString, pprCLabelString ) import Outputable -import SrcLoc ( SrcLoc ) +import SrcLoc ( SrcLoc, noSrcLoc ) import Util \end{code} @@ -53,6 +59,7 @@ data HsDecl name pat | ForD (ForeignDecl name) | SigD (IfaceSig name) | FixD (FixitySig name) + | DeprecD (DeprecDecl name) | RuleD (RuleDecl name pat) -- NB: all top-level fixity decls are contained EITHER @@ -74,18 +81,18 @@ data HsDecl name pat hsDeclName :: (Outputable name, Outputable pat) => HsDecl name pat -> name #endif -hsDeclName (TyClD decl) = tyClDeclName decl -hsDeclName (SigD (IfaceSig name _ _ _)) = name -hsDeclName (InstD (InstDecl _ _ _ name _)) = name -hsDeclName (ForD (ForeignDecl name _ _ _ _ _)) = name -hsDeclName (FixD (FixitySig name _ _)) = name +hsDeclName (TyClD decl) = tyClDeclName decl +hsDeclName (SigD (IfaceSig name _ _ _)) = name +hsDeclName (InstD (InstDecl _ _ _ name _)) = name +hsDeclName (ForD (ForeignDecl name _ _ _ _ _)) = name +hsDeclName (FixD (FixitySig name _ _)) = name -- Others don't make sense #ifdef DEBUG hsDeclName x = pprPanic "HsDecls.hsDeclName" (ppr x) #endif tyClDeclName :: TyClDecl name pat -> name -tyClDeclName (TyData _ _ name _ _ _ _ _) = name +tyClDeclName (TyData _ _ name _ _ _ _ _ _) = name tyClDeclName (TySynonym name _ _ _) = name tyClDeclName (ClassDecl _ name _ _ _ _ _ _ _ _ _ _) = name \end{code} @@ -102,6 +109,15 @@ instance (Outputable name, Outputable pat) ppr (ForD fd) = ppr fd ppr (FixD fd) = ppr fd ppr (RuleD rd) = ppr rd + ppr (DeprecD dd) = ppr dd +\end{code} + +\begin{code} +instance Ord name => Eq (HsDecl name pat) where + -- Used only when comparing interfaces, + -- at which time only signature and type/class decls + (SigD s1) == (SigD s2) = s1 == s2 + (TyClD d1) == (TyClD d2) = d1 == d2 \end{code} @@ -116,8 +132,9 @@ data TyClDecl name pat = TyData NewOrData (HsContext name) -- context name -- type constructor - [HsTyVar name] -- type variables + [HsTyVarBndr name] -- type variables [ConDecl name] -- data constructors (empty if abstract) + Int -- Number of data constructors (valid even if type is abstract) (Maybe [name]) -- derivings; Nothing => not specified -- (i.e., derive default); Just [] => derive -- *nothing*; Just <list> => as you would @@ -126,14 +143,14 @@ data TyClDecl name pat SrcLoc | TySynonym name -- type constructor - [HsTyVar name] -- type variables + [HsTyVarBndr name] -- type variables (HsType name) -- synonym expansion SrcLoc | ClassDecl (HsContext name) -- context... name -- name of the class - [HsTyVar name] -- the class type variables - [([name], [name])] -- functional dependencies + [HsTyVarBndr name] -- the class type variables + [FunDep name] -- functional dependencies [Sig name] -- methods' signatures (MonoBinds name pat) -- default methods (ClassPragmas name) @@ -141,6 +158,37 @@ data TyClDecl name pat -- and superclass selectors for this class. -- These are filled in as the ClassDecl is made. SrcLoc + +instance Ord name => Eq (TyClDecl name pat) where + -- Used only when building interface files + (==) (TyData nd1 cxt1 n1 tvs1 cons1 _ _ _ _) + (TyData nd2 cxt2 n2 tvs2 cons2 _ _ _ _) + = n1 == n2 && + nd1 == nd2 && + eqWithHsTyVars tvs1 tvs2 (\ env -> + eq_hsContext env cxt1 cxt2 && + eqListBy (eq_ConDecl env) cons1 cons2 + ) + + (==) (TySynonym n1 tvs1 ty1 _) + (TySynonym n2 tvs2 ty2 _) + = n1 == n2 && + eqWithHsTyVars tvs1 tvs2 (\ env -> eq_hsType env ty1 ty2) + + (==) (ClassDecl cxt1 n1 tvs1 fds1 sigs1 _ _ _ _ _ _ _) + (ClassDecl cxt2 n2 tvs2 fds2 sigs2 _ _ _ _ _ _ _) + = n1 == n2 && + eqWithHsTyVars tvs1 tvs2 (\ env -> + eq_hsContext env cxt1 cxt2 && + eqListBy (eq_hsFD env) fds1 fds2 && + eqListBy (eq_cls_sig env) sigs1 sigs2 + ) + +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 _ b1 ty1 _) (ClassOpSig n2 _ b2 ty2 _) + = n1==n2 && b1==b2 && eq_hsType env ty1 ty2 \end{code} \begin{code} @@ -148,8 +196,8 @@ countTyClDecls :: [TyClDecl name pat] -> (Int, Int, Int, Int) -- class, data, newtype, synonym decls countTyClDecls decls = (length [() | ClassDecl _ _ _ _ _ _ _ _ _ _ _ _ <- decls], - length [() | TyData DataType _ _ _ _ _ _ _ <- decls], - length [() | TyData NewType _ _ _ _ _ _ _ <- decls], + length [() | TyData DataType _ _ _ _ _ _ _ _ <- decls], + length [() | TyData NewType _ _ _ _ _ _ _ _ <- decls], length [() | TySynonym _ _ _ _ <- decls]) isDataDecl, isSynDecl, isClassDecl :: TyClDecl name pat -> Bool @@ -157,8 +205,8 @@ isDataDecl, isSynDecl, isClassDecl :: TyClDecl name pat -> Bool isSynDecl (TySynonym _ _ _ _) = True isSynDecl other = False -isDataDecl (TyData _ _ _ _ _ _ _ _) = True -isDataDecl other = False +isDataDecl (TyData _ _ _ _ _ _ _ _ _) = True +isDataDecl other = False isClassDecl (ClassDecl _ _ _ _ _ _ _ _ _ _ _ _) = True isClassDecl other = False @@ -169,13 +217,13 @@ instance (Outputable name, Outputable pat) => Outputable (TyClDecl name pat) where ppr (TySynonym tycon tyvars mono_ty src_loc) - = hang (pp_decl_head SLIT("type") empty tycon tyvars) + = hang (ptext SLIT("type") <+> pp_decl_head [] tycon tyvars <+> equals) 4 (ppr mono_ty) - ppr (TyData new_or_data context tycon tyvars condecls derivings pragmas src_loc) + ppr (TyData new_or_data context tycon tyvars condecls ncons derivings pragmas src_loc) = pp_tydecl - (pp_decl_head keyword (pprHsContext context) tycon tyvars) - (pp_condecls condecls) + (ptext keyword <+> pp_decl_head context tycon tyvars <+> equals) + (pp_condecls condecls ncons) derivings where keyword = case new_or_data of @@ -188,21 +236,19 @@ instance (Outputable name, Outputable pat) | otherwise -- Laid out = sep [hsep [top_matter, ptext SLIT("where {")], - nest 4 (vcat [sep (map ppr_sig sigs), - ppr methods, - char '}'])] + nest 4 (sep [sep (map ppr_sig sigs), pp_methods, char '}'])] where - top_matter = hsep [ptext SLIT("class"), pprHsContext context, - ppr clas, hsep (map (ppr) tyvars), pprFundeps fds] + top_matter = ptext SLIT("class") <+> pp_decl_head context clas tyvars <+> pprFundeps fds ppr_sig sig = ppr sig <> semi + pp_methods = getPprStyle $ \ sty -> + if ifaceStyle sty then empty else ppr methods + +pp_decl_head :: Outputable name => HsContext name -> name -> [HsTyVarBndr name] -> SDoc +pp_decl_head context thing tyvars = hsep [pprHsContext context, ppr thing, interppSP tyvars] -pp_decl_head str pp_context tycon tyvars - = hsep [ptext str, pp_context, ppr tycon, - interppSP tyvars, ptext SLIT("=")] - -pp_condecls [] = empty -- Curious! -pp_condecls (c:cs) = sep (ppr c : map (\ c -> ptext SLIT("|") <+> ppr c) cs) +pp_condecls [] ncons = ptext SLIT("{- abstract with") <+> int ncons <+> ptext SLIT("constructors -}") +pp_condecls (c:cs) ncons = sep (ppr c : map (\ c -> ptext SLIT("|") <+> ppr c) cs) pp_tydecl pp_head pp_decl_rhs derivings = hang pp_head 4 (sep [ @@ -244,7 +290,7 @@ data ConDecl name name -- Name of the constructor's 'worker Id' -- Filled in as the ConDecl is built - [HsTyVar name] -- Existentially quantified type variables + [HsTyVarBndr name] -- Existentially quantified type variables (HsContext name) -- ...and context -- If both are empty then there are no existentials @@ -270,12 +316,36 @@ data BangType name = Banged (HsType name) -- HsType: to allow Haskell extensions | Unbanged (HsType name) -- (MonoType only needed for straight Haskell) | Unpacked (HsType name) -- Field is strict and to be unpacked if poss. + + +eq_ConDecl env (ConDecl n1 _ tvs1 cxt1 cds1 _) + (ConDecl n2 _ tvs2 cxt2 cds2 _) + = n1 == n2 && + (eqWithHsTyVars tvs1 tvs2 $ \ env -> + eq_hsContext env cxt1 cxt2 && + eq_ConDetails env cds1 cds2) + +eq_ConDetails env (VanillaCon bts1) (VanillaCon 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 (NewCon t1 mn1) (NewCon t2 mn2) + = eq_hsType env t1 t2 && mn1 == mn2 +eq_ConDetails env _ _ = False + +eq_fld env (ns1,bt1) (ns2, bt2) = ns1==ns2 && eq_btype env bt1 bt2 + +eq_btype env (Banged t1) (Banged t2) = eq_hsType env t1 t2 +eq_btype env (Unbanged t1) (Unbanged t2) = eq_hsType env t1 t2 +eq_btype env (Unpacked t1) (Unpacked t2) = eq_hsType env t1 t2 \end{code} \begin{code} instance (Outputable name) => Outputable (ConDecl name) where ppr (ConDecl con _ tvs cxt con_details loc) - = sep [pprForAll tvs, pprHsContext cxt, ppr_con_details con con_details] + = 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] @@ -334,14 +404,21 @@ instance (Outputable name, Outputable pat) ppr (InstDecl inst_ty binds uprags dfun_name src_loc) = getPprStyle $ \ sty -> - if ifaceStyle sty || (nullMonoBinds binds && null uprags) then - hsep [ptext SLIT("instance"), ppr inst_ty] + if ifaceStyle sty then + hsep [ptext SLIT("instance"), ppr inst_ty, equals, ppr dfun_name] else vcat [hsep [ptext SLIT("instance"), ppr inst_ty, ptext SLIT("where")], nest 4 (ppr uprags), nest 4 (ppr binds) ] \end{code} +\begin{code} +instance Ord name => Eq (InstDecl name pat) 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} + %************************************************************************ %* * @@ -431,7 +508,7 @@ instance Outputable ExtName where \begin{code} data RuleDecl name pat - = RuleDecl + = HsRule -- Source rule FAST_STRING -- Rule name [name] -- Forall'd tyvars, filled in by the renamer with -- tyvars mentioned in sigs; then filled out by typechecker @@ -440,18 +517,33 @@ data RuleDecl name pat (HsExpr name pat) -- RHS SrcLoc - | IfaceRuleDecl -- One that's come in from an interface file - name - (UfRuleBody name) + | IfaceRule -- One that's come in from an interface file; pre-typecheck + FAST_STRING + [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 + + data RuleBndr name = RuleBndr name | RuleBndrSig name (HsType name) +instance Ord name => Eq (RuleDecl name pat) where + -- Works for IfaceRules only; used when comparing interface file versions + (IfaceRule n1 bs1 f1 es1 rhs1 _) == (IfaceRule n2 bs2 f2 es2 rhs2 _) + = n1==n2 && f1 == f2 && + eq_ufBinders emptyEqHsEnv bs1 bs2 (\env -> + eqListBy (eq_ufExpr env) (rhs1:es1) (rhs2:es2)) + instance (Outputable name, Outputable pat) => Outputable (RuleDecl name pat) where - ppr (RuleDecl name tvs ns lhs rhs loc) + ppr (HsRule name tvs ns lhs rhs loc) = sep [text "{-# RULES" <+> doubleQuotes (ptext name), pp_forall, ppr lhs, equals <+> ppr rhs, text "#-}" ] @@ -460,9 +552,49 @@ instance (Outputable name, Outputable pat) | otherwise = text "forall" <+> fsep (map ppr tvs ++ map ppr ns) <> dot - ppr (IfaceRuleDecl var body loc) = text "An imported rule..." + + ppr (IfaceRule name tpl_vars fn tpl_args rhs loc) + = hsep [ doubleQuotes (ptext name), + 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 Outputable name => Outputable (RuleBndr name) where ppr (RuleBndr name) = ppr name ppr (RuleBndrSig name ty) = ppr name <> dcolon <> ppr ty + +toHsRule id (BuiltinRule _) + = pprTrace "toHsRule: builtin" (ppr id) (bogusIfaceRule id) + +toHsRule id (Rule name bndrs args rhs) + = IfaceRule name (map toUfBndr bndrs) (toRdrName id) + (map toUfExpr args) (toUfExpr rhs) noSrcLoc + +bogusIfaceRule id + = IfaceRule SLIT("bogus") [] (toRdrName id) [] (UfVar (toRdrName id)) noSrcLoc +\end{code} + + +%************************************************************************ +%* * +\subsection[DeprecDecl]{Deprecations} +%* * +%************************************************************************ + +We use exported entities for things to deprecate. Cunning trick (hack?): +`IEModuleContents undefined' is used for module deprecation. + +\begin{code} +data DeprecDecl name = Deprecation (IE name) DeprecTxt SrcLoc + +type DeprecTxt = FAST_STRING -- reason/explanation for deprecation + +instance Outputable name => Outputable (DeprecDecl name) where + ppr (Deprecation (IEModuleContents _) txt _) + = hsep [text "{-# DEPRECATED", doubleQuotes (ppr txt), text "#-}"] + ppr (Deprecation thing txt _) + = hsep [text "{-# DEPRECATED", ppr thing, doubleQuotes (ppr txt), text "#-}"] \end{code} diff --git a/ghc/compiler/hsSyn/HsExpr.lhs b/ghc/compiler/hsSyn/HsExpr.lhs index 620f060bb0..fb4429dba0 100644 --- a/ghc/compiler/hsSyn/HsExpr.lhs +++ b/ghc/compiler/hsSyn/HsExpr.lhs @@ -24,6 +24,7 @@ import Type ( Type ) import Var ( TyVar, Id ) import DataCon ( DataCon ) import CStrings ( CLabelString, pprCLabelString ) +import BasicTypes ( Boxity, tupleParens ) import SrcLoc ( SrcLoc ) \end{code} @@ -107,7 +108,7 @@ data HsExpr id pat -- NB: Unit is ExplicitTuple [] -- for tuples, we can get the types -- direct from the components - Bool -- boxed? + Boxity -- Record construction @@ -307,11 +308,8 @@ ppr_expr (ExplicitListOut ty exprs) = hcat [ brackets (fsep (punctuate comma (map ppr_expr exprs))), ifNotPprForUser ((<>) space (parens (pprType ty))) ] -ppr_expr (ExplicitTuple exprs True) - = parens (sep (punctuate comma (map ppr_expr exprs))) - -ppr_expr (ExplicitTuple exprs False) - = ptext SLIT("(#") <> sep (punctuate comma (map ppr_expr exprs)) <> ptext SLIT("#)") +ppr_expr (ExplicitTuple exprs boxity) + = tupleParens boxity (sep (punctuate comma (map ppr_expr exprs))) ppr_expr (RecordCon con_id rbinds) = pp_rbinds (ppr con_id) rbinds diff --git a/ghc/compiler/hsSyn/HsImpExp.lhs b/ghc/compiler/hsSyn/HsImpExp.lhs index 7800a025d5..5ee977726b 100644 --- a/ghc/compiler/hsSyn/HsImpExp.lhs +++ b/ghc/compiler/hsSyn/HsImpExp.lhs @@ -71,6 +71,13 @@ ieName (IEVar n) = n ieName (IEThingAbs n) = n ieName (IEThingWith n _) = n ieName (IEThingAll n) = n + +ieNames :: IE a -> [a] +ieNames (IEVar n ) = [n] +ieNames (IEThingAbs n ) = [n] +ieNames (IEThingAll n ) = [n] +ieNames (IEThingWith n ns) = n:ns +ieNames (IEModuleContents _ ) = [] \end{code} \begin{code} diff --git a/ghc/compiler/hsSyn/HsMatches.lhs b/ghc/compiler/hsSyn/HsMatches.lhs index 94409c43f7..640c717148 100644 --- a/ghc/compiler/hsSyn/HsMatches.lhs +++ b/ghc/compiler/hsSyn/HsMatches.lhs @@ -13,7 +13,7 @@ module HsMatches where -- Friends import HsExpr ( HsExpr, Stmt(..) ) import HsBinds ( HsBinds(..), nullBinds ) -import HsTypes ( HsTyVar, HsType ) +import HsTypes ( HsTyVarBndr, HsType ) -- Others import Type ( Type ) @@ -44,7 +44,7 @@ patterns in each equation. \begin{code} data Match id pat = Match - [HsTyVar id] -- Tyvars wrt which this match is universally quantified + [HsTyVarBndr id] -- Tyvars wrt which this match is universally quantified -- emtpy after typechecking [pat] -- The patterns (Maybe (HsType id)) -- A type signature for the result of the match diff --git a/ghc/compiler/hsSyn/HsPat.lhs b/ghc/compiler/hsSyn/HsPat.lhs index b83d5022a2..6e4051ec83 100644 --- a/ghc/compiler/hsSyn/HsPat.lhs +++ b/ghc/compiler/hsSyn/HsPat.lhs @@ -21,7 +21,7 @@ module HsPat ( import HsBasic ( HsLit ) import HsExpr ( HsExpr ) import HsTypes ( HsType ) -import BasicTypes ( Fixity ) +import BasicTypes ( Fixity, Boxity, tupleParens ) -- others: import Var ( Id, TyVar ) @@ -61,7 +61,7 @@ data InPat name | ListPatIn [InPat name] -- syntactic list -- must have >= 1 elements - | TuplePatIn [InPat name] Bool -- tuple (boxed?) + | TuplePatIn [InPat name] Boxity -- tuple (boxed?) | RecPatIn name -- record [(name, InPat name, Bool)] -- True <=> source used punning @@ -78,7 +78,7 @@ data OutPat id [OutPat id] | TuplePat [OutPat id] -- tuple - Bool -- boxed? + Boxity -- UnitPat is TuplePat [] | ConPat DataCon @@ -165,10 +165,8 @@ pprInPat (ParPatIn pat) pprInPat (ListPatIn pats) = brackets (interpp'SP pats) -pprInPat (TuplePatIn pats False) - = text "(#" <> (interpp'SP pats) <> text "#)" -pprInPat (TuplePatIn pats True) - = parens (interpp'SP pats) +pprInPat (TuplePatIn pats boxity) + = tupleParens boxity (interpp'SP pats) pprInPat (NPlusKPatIn n k) = parens (hcat [ppr n, char '+', ppr k]) @@ -205,12 +203,8 @@ pprOutPat (ConPat name ty tyvars dicts pats) hsep [ppr p1, ppr name, ppr p2] _ -> hsep [ppr name, interppSP tyvars, interppSP dicts, interppSP pats] -pprOutPat (ListPat ty pats) - = brackets (interpp'SP pats) -pprOutPat (TuplePat pats boxed@True) - = parens (interpp'SP pats) -pprOutPat (TuplePat pats unboxed@False) - = text "(#" <> (interpp'SP pats) <> text "#)" +pprOutPat (ListPat ty pats) = brackets (interpp'SP pats) +pprOutPat (TuplePat pats boxity) = tupleParens boxity (interpp'SP pats) pprOutPat (RecPat con ty tvs dicts rpats) = hsep [ppr con, interppSP tvs, interppSP dicts, braces (hsep (punctuate comma (map (pp_rpat) rpats)))] diff --git a/ghc/compiler/hsSyn/HsTypes.lhs b/ghc/compiler/hsSyn/HsTypes.lhs index 2536e8d07c..a795a2f1ae 100644 --- a/ghc/compiler/hsSyn/HsTypes.lhs +++ b/ghc/compiler/hsSyn/HsTypes.lhs @@ -5,71 +5,101 @@ \begin{code} module HsTypes ( - HsType(..), MonoUsageAnn(..), HsTyVar(..), - HsContext, HsClassAssertion, HsPred(..) + HsType(..), HsUsageAnn(..), HsTyVarBndr(..), + , HsContext, HsPred(..) + , HsTupCon(..), hsTupParens, mkHsTupCon, - , mkHsForAllTy, mkHsUsForAllTy + , mkHsForAllTy, mkHsUsForAllTy, mkHsDictTy, mkHsIParamTy , getTyVarName, replaceTyVarName - , pprParendHsType - , pprForAll, pprHsContext, pprHsClassAssertion, pprHsPred - , cmpHsType, cmpHsTypes, cmpHsContext, cmpHsPred + + -- Printing + , pprParendHsType, pprHsForAll, pprHsContext, pprHsTyVarBndr + + -- Equality over Hs things + , EqHsEnv, emptyEqHsEnv, extendEqHsEnv, + , eqWithHsTyVars, eq_hsVar, eq_hsVars, eq_hsType, eq_hsContext, eqListBy + + -- Converting from Type to HsType + , toHsType, toHsTyVar, toHsTyVars, toHsContext, toHsFDs ) where #include "HsVersions.h" -import Type ( Kind, UsageAnn(..) ) -import PprType ( {- instance Outputable Kind -} ) +import Class ( FunDep ) +import Type ( Type, Kind, PredType(..), UsageAnn(..), ClassContext, + getTyVar_maybe, splitFunTy_maybe, splitAppTy_maybe, + splitTyConApp_maybe, splitPredTy_maybe, + splitUsgTy, splitSigmaTy, unUsgTy, boxedTypeKind + ) +import TypeRep ( Type(..), TyNote(..) ) -- toHsType sees the representation +import TyCon ( isTupleTyCon, tupleTyConBoxity, tyConArity, tyConClass_maybe ) +import PrelInfo ( mkTupConRdrName ) +import RdrName ( RdrName ) +import Name ( toRdrName ) +import OccName ( NameSpace ) +import Var ( TyVar, tyVarKind ) +import PprType ( {- instance Outputable Kind -}, pprParendKind ) +import BasicTypes ( Arity, Boxity(..), tupleParens ) +import Unique ( hasKey, listTyConKey, Uniquable(..) ) +import Maybes ( maybeToBool ) +import FiniteMap import Outputable -import Util ( thenCmp, cmpList ) \end{code} This is the syntax for types as seen in type signatures. \begin{code} type HsContext name = [HsPred name] -type HsClassAssertion name = (name, [HsType name]) --- The type is usually a type variable, but it --- doesn't have to be when reading interface files -data HsPred name = - HsPClass name [HsType name] - | HsPIParam name (HsType name) + +data HsPred name = HsPClass name [HsType name] + | HsPIParam name (HsType name) data HsType name - = HsForAllTy (Maybe [HsTyVar name]) -- Nothing for implicitly quantified signatures - (HsContext name) - (HsType name) + = HsForAllTy (Maybe [HsTyVarBndr name]) -- Nothing for implicitly quantified signatures + (HsContext name) + (HsType name) - | MonoTyVar name -- Type variable + | HsTyVar name -- Type variable - | MonoTyApp (HsType name) + | HsAppTy (HsType name) (HsType name) - | MonoFunTy (HsType name) -- function type + | HsFunTy (HsType name) -- function type (HsType name) - | MonoListTy (HsType name) -- Element type - - | MonoTupleTy [HsType name] -- Element types (length gives arity) - Bool -- boxed? + | HsListTy (HsType name) -- Element type - | MonoIParamTy name (HsType name) + | HsTupleTy (HsTupCon name) + [HsType name] -- Element types (length gives arity) -- these next two are only used in interfaces - | MonoDictTy name -- Class - [HsType name] + | HsPredTy (HsPred name) - | MonoUsgTy (MonoUsageAnn name) + | HsUsgTy (HsUsageAnn name) (HsType name) - | MonoUsgForAllTy name + | HsUsgForAllTy name (HsType name) -data MonoUsageAnn name - = MonoUsOnce - | MonoUsMany - | MonoUsVar name +data HsUsageAnn name + = HsUsOnce + | HsUsMany + | HsUsVar name +----------------------- +data HsTupCon name = HsTupCon name Boxity + +instance Eq name => Eq (HsTupCon name) where + (HsTupCon _ b1) == (HsTupCon _ b2) = b1==b2 + +mkHsTupCon :: NameSpace -> Boxity -> [a] -> HsTupCon RdrName +mkHsTupCon space boxity args = HsTupCon (mkTupConRdrName space boxity (length args)) boxity + +hsTupParens :: HsTupCon name -> SDoc -> SDoc +hsTupParens (HsTupCon _ b) p = tupleParens b p + +----------------------- -- Combine adjacent for-alls. -- The following awkward situation can happen otherwise: -- f :: forall a. ((Num a) => Int) @@ -87,10 +117,13 @@ mkHsForAllTy mtvs1 [] (HsForAllTy mtvs2 ctxt ty) = mkHsForAllTy (mtvs1 `plus (Just tvs1) `plus` (Just tvs2) = Just (tvs1 ++ tvs2) mkHsForAllTy tvs ctxt ty = HsForAllTy tvs ctxt ty -mkHsUsForAllTy uvs ty = foldr (\ uv ty -> MonoUsgForAllTy uv ty) +mkHsUsForAllTy uvs ty = foldr (\ uv ty -> HsUsgForAllTy uv ty) ty uvs -data HsTyVar name +mkHsDictTy cls tys = HsPredTy (HsPClass cls tys) +mkHsIParamTy v ty = HsPredTy (HsPIParam v ty) + +data HsTyVarBndr name = UserTyVar name | IfaceTyVar name Kind -- *** NOTA BENE *** A "monotype" in a pragma can have @@ -100,7 +133,7 @@ data HsTyVar name getTyVarName (UserTyVar n) = n getTyVarName (IfaceTyVar n _) = n -replaceTyVarName :: HsTyVar name1 -> name2 -> HsTyVar name2 +replaceTyVarName :: HsTyVarBndr name1 -> name2 -> HsTyVarBndr name2 replaceTyVarName (UserTyVar n) n' = UserTyVar n' replaceTyVarName (IfaceTyVar n k) n' = IfaceTyVar n' k \end{code} @@ -113,31 +146,30 @@ replaceTyVarName (IfaceTyVar n k) n' = IfaceTyVar n' k %************************************************************************ \begin{code} - instance (Outputable name) => Outputable (HsType name) where ppr ty = pprHsType ty -instance (Outputable name) => Outputable (HsTyVar name) where +instance (Outputable name) => Outputable (HsTyVarBndr name) where ppr (UserTyVar name) = ppr name - ppr (IfaceTyVar name kind) = hsep [ppr name, dcolon, ppr kind] + ppr (IfaceTyVar name kind) = pprHsTyVarBndr name kind + +instance Outputable name => Outputable (HsPred name) where + ppr (HsPClass clas tys) = ppr clas <+> hsep (map pprParendHsType tys) + ppr (HsPIParam n ty) = hsep [{- char '?' <> -} ppr n, text "::", ppr ty] --- Better to see those for-alls --- pprForAll [] = empty -pprForAll tvs = ptext SLIT("forall") <+> interppSP tvs <> ptext SLIT(".") +pprHsTyVarBndr :: Outputable name => name -> Kind -> SDoc +pprHsTyVarBndr name kind | kind == boxedTypeKind = ppr name + | otherwise = hsep [ppr name, dcolon, pprParendKind kind] + +pprHsForAll [] [] = empty +pprHsForAll tvs cxt = ptext SLIT("__forall") <+> interppSP tvs <+> ppr_context cxt <+> ptext SLIT("=>") pprHsContext :: (Outputable name) => HsContext name -> SDoc -pprHsContext [] = empty -pprHsContext context = parens (hsep (punctuate comma (map pprHsPred context))) <+> ptext SLIT("=>") - -pprHsClassAssertion :: (Outputable name) => HsClassAssertion name -> SDoc -pprHsClassAssertion (clas, tys) - = ppr clas <+> hsep (map pprParendHsType tys) - -pprHsPred :: (Outputable name) => HsPred name -> SDoc -pprHsPred (HsPClass clas tys) - = ppr clas <+> hsep (map pprParendHsType tys) -pprHsPred (HsPIParam n ty) - = hsep [{- char '?' <> -} ppr n, text "::", ppr ty] +pprHsContext [] = empty +pprHsContext cxt = ppr_context cxt <+> ptext SLIT("=>") + +ppr_context [] = empty +ppr_context cxt = parens (interpp'SP cxt) \end{code} \begin{code} @@ -158,42 +190,35 @@ pprParendHsType ty = ppr_mono_ty pREC_CON ty ppr_mono_ty ctxt_prec (HsForAllTy maybe_tvs ctxt ty) = maybeParen (ctxt_prec >= pREC_FUN) $ - sep [pp_tvs, pprHsContext ctxt, pprHsType ty] + sep [pp_header, pprHsType ty] where - pp_tvs = case maybe_tvs of - Just tvs -> pprForAll tvs - Nothing -> text "{- implicit forall -}" + pp_header = case maybe_tvs of + Just tvs -> pprHsForAll tvs ctxt + Nothing -> pprHsContext ctxt -ppr_mono_ty ctxt_prec (MonoTyVar name) +ppr_mono_ty ctxt_prec (HsTyVar name) = ppr name -ppr_mono_ty ctxt_prec (MonoFunTy ty1 ty2) +ppr_mono_ty ctxt_prec (HsFunTy ty1 ty2) = let p1 = ppr_mono_ty pREC_FUN ty1 p2 = ppr_mono_ty pREC_TOP ty2 in maybeParen (ctxt_prec >= pREC_FUN) (sep [p1, (<>) (ptext SLIT("-> ")) p2]) -ppr_mono_ty ctxt_prec (MonoTupleTy tys True) - = parens (sep (punctuate comma (map ppr tys))) -ppr_mono_ty ctxt_prec (MonoTupleTy tys False) - = ptext SLIT("(#") <> sep (punctuate comma (map ppr tys)) <> ptext SLIT("#)") +ppr_mono_ty ctxt_prec (HsTupleTy con tys) = hsTupParens con (interpp'SP tys) +ppr_mono_ty ctxt_prec (HsListTy ty) = brackets (ppr_mono_ty pREC_TOP ty) -ppr_mono_ty ctxt_prec (MonoListTy ty) - = brackets (ppr_mono_ty pREC_TOP ty) - -ppr_mono_ty ctxt_prec (MonoTyApp fun_ty arg_ty) +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 (MonoIParamTy n ty) - = hsep [{- char '?' <> -} ppr n, text "::", ppr_mono_ty pREC_TOP ty] - -ppr_mono_ty ctxt_prec (MonoDictTy clas tys) - = ppr clas <+> hsep (map (ppr_mono_ty pREC_CON) tys) - -ppr_mono_ty ctxt_prec ty@(MonoUsgForAllTy _ _) +ppr_mono_ty ctxt_prec (HsPredTy pred) = maybeParen (ctxt_prec >= pREC_FUN) $ + braces (ppr pred) + +ppr_mono_ty ctxt_prec ty@(HsUsgForAllTy _ _) + = sep [ ptext SLIT("__fuall") <+> brackets pp_uvars <+> ptext SLIT("=>"), ppr_mono_ty pREC_TOP sigma ] @@ -201,17 +226,83 @@ ppr_mono_ty ctxt_prec ty@(MonoUsgForAllTy _ _) (uvars,sigma) = split [] ty pp_uvars = interppSP uvars - split uvs (MonoUsgForAllTy uv ty') = split (uv:uvs) ty' + split uvs (HsUsgForAllTy uv ty') = split (uv:uvs) ty' split uvs ty' = (reverse uvs,ty') -ppr_mono_ty ctxt_prec (MonoUsgTy u ty) +ppr_mono_ty ctxt_prec (HsUsgTy u ty) = maybeParen (ctxt_prec >= pREC_CON) $ ptext SLIT("__u") <+> pp_ua <+> ppr_mono_ty pREC_CON ty where pp_ua = case u of - MonoUsOnce -> ptext SLIT("-") - MonoUsMany -> ptext SLIT("!") - MonoUsVar uv -> ppr uv + HsUsOnce -> ptext SLIT("-") + HsUsMany -> ptext SLIT("!") + HsUsVar uv -> ppr uv +\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 RdrName +toHsTyVar tv = IfaceTyVar (toRdrName tv) (tyVarKind tv) + +toHsTyVars tvs = map toHsTyVar tvs + +toHsType :: Type -> HsType RdrName +toHsType ty = toHsType' (unUsgTy ty) + -- For now we just discard the usage +-- = case splitUsgTy ty of +-- (usg, tau) -> HsUsgTy (toHsUsg usg) (toHsType' tau) + +toHsType' :: Type -> HsType RdrName +-- Called after the usage is stripped off +-- This function knows the representation of types +toHsType' (TyVarTy tv) = HsTyVar (toRdrName tv) +toHsType' (FunTy arg res) = HsFunTy (toHsType arg) (toHsType res) +toHsType' (AppTy fun arg) = HsAppTy (toHsType fun) (toHsType arg) + +toHsType' (NoteTy (SynNote ty) _) = toHsType ty -- Use synonyms if possible!! +toHsType' (NoteTy _ ty) = toHsType ty + +toHsType' ty@(TyConApp tc tys) -- Must be saturated because toHsType's arg is of kind * + | not saturated = generic_case + | isTupleTyCon tc = HsTupleTy (HsTupCon (toRdrName tc) (tupleTyConBoxity tc)) tys' + | tc `hasKey` listTyConKey = HsListTy (head tys') + | maybeToBool maybe_class = HsPredTy (HsPClass (toRdrName clas) tys') + | otherwise = generic_case + where + generic_case = foldl HsAppTy (HsTyVar (toRdrName tc)) tys' + maybe_class = tyConClass_maybe tc + Just clas = maybe_class + tys' = map toHsType tys + saturated = length tys == tyConArity tc + +toHsType' ty@(ForAllTy _ _) = case splitSigmaTy ty of + (tvs, preds, tau) -> HsForAllTy (Just (map toHsTyVar tvs)) + (map toHsPred preds) + (toHsType tau) + + +toHsPred (Class cls tys) = HsPClass (toRdrName cls) (map toHsType tys) +toHsPred (IParam n ty) = HsPIParam (toRdrName n) (toHsType ty) + +toHsContext :: ClassContext -> HsContext RdrName +toHsContext cxt = [HsPClass (toRdrName cls) (map toHsType tys) | (cls,tys) <- cxt] + +toHsUsg UsOnce = HsUsOnce +toHsUsg UsMany = HsUsMany +toHsUsg (UsVar v) = HsUsVar (toRdrName v) + +toHsFDs :: [FunDep TyVar] -> [FunDep RdrName] +toHsFDs fds = [(map toRdrName ns, map toRdrName ms) | (ns,ms) <- fds] \end{code} @@ -221,97 +312,115 @@ ppr_mono_ty ctxt_prec (MonoUsgTy u ty) %* * %************************************************************************ +\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. Most any other use is likely to be {\em -wrong}, so be careful! +in checking interfaces. \begin{code} -cmpHsTyVar :: (a -> a -> Ordering) -> HsTyVar a -> HsTyVar a -> Ordering -cmpHsType :: (a -> a -> Ordering) -> HsType a -> HsType a -> Ordering -cmpHsTypes :: (a -> a -> Ordering) -> [HsType a] -> [HsType a] -> Ordering -cmpHsContext :: (a -> a -> Ordering) -> HsContext a -> HsContext a -> Ordering -cmpHsPred :: (a -> a -> Ordering) -> HsPred a -> HsPred a -> Ordering +------------------- +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 == 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} -cmpHsTyVar cmp (UserTyVar v1) (UserTyVar v2) = v1 `cmp` v2 -cmpHsTyVar cmp (IfaceTyVar v1 _) (IfaceTyVar v2 _) = v1 `cmp` v2 -cmpHsTyVar cmp (UserTyVar _) other = LT -cmpHsTyVar cmp other1 other2 = GT +\begin{code} +------------------- +eq_hsTypes env = eqListBy (eq_hsType env) -cmpHsTypes cmp [] [] = EQ -cmpHsTypes cmp [] tys2 = LT -cmpHsTypes cmp tys1 [] = GT -cmpHsTypes cmp (ty1:tys1) (ty2:tys2) = cmpHsType cmp ty1 ty2 `thenCmp` cmpHsTypes cmp tys1 tys2 +------------------- +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 -cmpHsType cmp (HsForAllTy tvs1 c1 t1) (HsForAllTy tvs2 c2 t2) - = cmpMaybe (cmpList (cmpHsTyVar cmp)) tvs1 tvs2 `thenCmp` - cmpHsContext cmp c1 c2 `thenCmp` - cmpHsType cmp t1 t2 +eq_hsType env (HsTyVar n1) (HsTyVar n2) + = eq_hsVar env n1 n2 -cmpHsType cmp (MonoTyVar n1) (MonoTyVar n2) - = cmp n1 n2 +eq_hsType env (HsTupleTy c1 tys1) (HsTupleTy c2 tys2) + = (c1 == c2) && eq_hsTypes env tys1 tys2 -cmpHsType cmp (MonoTupleTy tys1 b1) (MonoTupleTy tys2 b2) - = (b1 `compare` b2) `thenCmp` cmpHsTypes cmp tys1 tys2 +eq_hsType env (HsListTy ty1) (HsListTy ty2) + = eq_hsType env ty1 ty2 -cmpHsType cmp (MonoListTy ty1) (MonoListTy ty2) - = cmpHsType cmp 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 -cmpHsType cmp (MonoTyApp fun_ty1 arg_ty1) (MonoTyApp fun_ty2 arg_ty2) - = cmpHsType cmp fun_ty1 fun_ty2 `thenCmp` cmpHsType cmp arg_ty1 arg_ty2 +eq_hsType env (HsFunTy a1 b1) (HsFunTy a2 b2) + = eq_hsType env a1 a2 && eq_hsType env b1 b2 -cmpHsType cmp (MonoFunTy a1 b1) (MonoFunTy a2 b2) - = cmpHsType cmp a1 a2 `thenCmp` cmpHsType cmp b1 b2 +eq_hsType env (HsPredTy p1) (HsPredTy p2) + = eq_hsPred env p1 p2 -cmpHsType cmp (MonoDictTy c1 tys1) (MonoDictTy c2 tys2) - = cmp c1 c2 `thenCmp` cmpHsTypes cmp tys1 tys2 +eq_hsType env (HsUsgTy u1 ty1) (HsUsgTy u2 ty2) + = eqUsg u1 u2 && eq_hsType env ty1 ty2 -cmpHsType cmp (MonoUsgTy u1 ty1) (MonoUsgTy u2 ty2) - = cmpUsg cmp u1 u2 `thenCmp` cmpHsType cmp ty1 ty2 +eq_hsType env ty1 ty2 = False -cmpHsType cmp ty1 ty2 -- tags must be different - = let tag1 = tag ty1 - tag2 = tag ty2 - in - if tag1 _LT_ tag2 then LT else GT - where - tag (MonoTyVar n1) = (ILIT(1) :: FAST_INT) - tag (MonoTupleTy tys1 _) = ILIT(2) - tag (MonoListTy ty1) = ILIT(3) - tag (MonoTyApp tc1 tys1) = ILIT(4) - tag (MonoFunTy a1 b1) = ILIT(5) - tag (MonoDictTy c1 tys1) = ILIT(6) - tag (MonoUsgTy c1 ty1) = ILIT(7) - tag (MonoUsgForAllTy uv1 ty1) = ILIT(8) - tag (HsForAllTy _ _ _) = ILIT(9) ------------------- -cmpHsContext cmp a b - = cmpList (cmpHsPred cmp) a b - -cmpHsPred cmp (HsPClass c1 tys1) (HsPClass c2 tys2) - = cmp c1 c2 `thenCmp` cmpHsTypes cmp tys1 tys2 -cmpHsPred cmp (HsPIParam n1 ty1) (HsPIParam n2 ty2) - = cmp n1 n2 `thenCmp` cmpHsType cmp ty1 ty2 -cmpHsPred cmp (HsPClass _ _) (HsPIParam _ _) = LT -cmpHsPred cmp _ _ = GT - -cmpUsg cmp MonoUsOnce MonoUsOnce = EQ -cmpUsg cmp MonoUsMany MonoUsMany = EQ -cmpUsg cmp (MonoUsVar u1) (MonoUsVar u2) = cmp u1 u2 - -cmpUsg cmp ua1 ua2 -- tags must be different - = let tag1 = tag ua1 - tag2 = tag ua2 - in - if tag1 _LT_ tag2 then LT else GT - where - tag MonoUsOnce = (ILIT(1) :: FAST_INT) - tag MonoUsMany = ILIT(2) - tag (MonoUsVar _) = ILIT(3) - --- Should be in Maybes, I guess -cmpMaybe cmp Nothing Nothing = EQ -cmpMaybe cmp Nothing (Just x) = LT -cmpMaybe cmp (Just x) Nothing = GT -cmpMaybe cmp (Just x) (Just y) = x `cmp` y +eq_hsContext env a b = eqListBy (eq_hsPred env) a b + +------------------- +eq_hsPred env (HsPClass c1 tys1) (HsPClass c2 tys2) + = c1 == c2 && eq_hsTypes env tys1 tys2 +eq_hsPred env (HsPIParam n1 ty1) (HsPIParam n2 ty2) + = n1 == n2 && eq_hsType env ty1 ty2 +eq_hsPred env _ _ = False + +------------------- +eqUsg HsUsOnce HsUsOnce = True +eqUsg HsUsMany HsUsMany = True +eqUsg (HsUsVar u1) (HsUsVar u2) = u1 == u2 +eqUsg _ _ = False + +------------------- +eqListBy :: (a->a->Bool) -> [a] -> [a] -> Bool +eqListBy eq [] [] = True +eqListBy eq (x:xs) (y:ys) = eq x y && eqListBy eq xs ys +eqListBy eq xs ys = False \end{code} diff --git a/ghc/compiler/main/CmdLineOpts.lhs b/ghc/compiler/main/CmdLineOpts.lhs index ca1b58d012..25d080ea68 100644 --- a/ghc/compiler/main/CmdLineOpts.lhs +++ b/ghc/compiler/main/CmdLineOpts.lhs @@ -137,6 +137,7 @@ module CmdLineOpts ( opt_ProduceExportCStubs, opt_ProduceExportHStubs, opt_ProduceHi, + opt_NoPruneTyDecls, opt_NoPruneDecls, opt_ReportCompile, opt_SourceUnchanged, @@ -453,6 +454,7 @@ opt_UF_DearOp = ( 4 :: Int) opt_ReportCompile = lookUp SLIT("-freport-compile") opt_NoPruneDecls = lookUp SLIT("-fno-prune-decls") +opt_NoPruneTyDecls = lookUp SLIT("-fno-prune-tydecls") opt_SourceUnchanged = lookUp SLIT("-fsource-unchanged") opt_Static = lookUp SLIT("-static") opt_Unregisterised = lookUp SLIT("-funregisterised") diff --git a/ghc/compiler/main/CodeOutput.lhs b/ghc/compiler/main/CodeOutput.lhs index 18b538b168..6c64a5c41e 100644 --- a/ghc/compiler/main/CodeOutput.lhs +++ b/ghc/compiler/main/CodeOutput.lhs @@ -32,7 +32,7 @@ import CmdLineOpts import Maybes ( maybeToBool ) import ErrUtils ( doIfSet, dumpIfSet ) import Outputable -import IO +import IO ( IOMode(..), hClose, openFile ) \end{code} @@ -109,8 +109,8 @@ outputAsm flat_absC ncg_uniqs #else /* OMIT_NATIVE_CODEGEN */ - = do hPutStrLn stderr "This compiler was built without a native code generator" - hPutStrLn stderr "Use -fvia-C instead" + = pprPanic "This compiler was built without a native code generator" + (text "Use -fvia-C instead") #endif \end{code} diff --git a/ghc/compiler/main/Constants.lhs b/ghc/compiler/main/Constants.lhs index 641b9f769b..771b5132c8 100644 --- a/ghc/compiler/main/Constants.lhs +++ b/ghc/compiler/main/Constants.lhs @@ -207,8 +207,9 @@ wORD64_SIZE = (WORD64_SIZE :: Int) iNT64_SIZE = (INT64_SIZE :: Int) \end{code} -The version of the interface file format we're -using: +The version of the interface file format we're using. It's propagated +here by a devious route from ghc/mk/version.mk. See comments +there for what it means. \begin{code} interfaceFileFormatVersion :: Int diff --git a/ghc/compiler/main/Main.lhs b/ghc/compiler/main/Main.lhs index 4ffef76d06..beb70cba7d 100644 --- a/ghc/compiler/main/Main.lhs +++ b/ghc/compiler/main/Main.lhs @@ -20,9 +20,8 @@ import Lex ( PState(..), P, ParseResult(..) ) import SrcLoc ( mkSrcLoc ) import Rename ( renameModule ) -import RnMonad ( InterfaceDetails(..) ) -import MkIface ( startIface, ifaceDecls, endIface ) +import MkIface ( writeIface ) import TcModule ( TcResults(..), typecheckModule ) import Desugar ( deSugar ) import SimplCore ( core2core ) @@ -124,24 +123,18 @@ doIt (core_cmds, stg_cmds) reportCompile mod_name "Compilation NOT required!" >> return (); - Just (this_mod, rn_mod, iface_file_stuff@(InterfaceDetails _ _ _ deprecations), - rn_name_supply, imported_modules) -> + Just (this_mod, rn_mod, + old_iface, new_iface, + rn_name_supply, fixity_env, + imported_modules) -> -- Oh well, we've got to recompile for real - -------------------------- Start interface file ---------------- - -- Safely past renaming: we can start the interface file: - -- (the iface file is produced incrementally, as we have - -- the information that we need...; we use "iface<blah>") - -- "endIface" finishes the job. - startIface this_mod iface_file_stuff >>= \ if_handle -> - - -------------------------- Typechecking ---------------- show_pass "TypeCheck" >> _scc_ "TypeCheck" typecheckModule tc_uniqs rn_name_supply - iface_file_stuff rn_mod >>= \ maybe_tc_stuff -> + fixity_env rn_mod >>= \ maybe_tc_stuff -> case maybe_tc_stuff of { Nothing -> ghcExit 1; -- Type checker failed @@ -163,6 +156,12 @@ doIt (core_cmds, stg_cmds) tidyCorePgm tidy_uniqs this_mod simplified orphan_rules >>= \ (tidy_binds, tidy_orphan_rules) -> + coreBindsSize tidy_binds `seq` +-- TEMP: the above call zaps some space usage allocated by the +-- simplifier, which for reasons I don't understand, persists +-- thoroughout code generation + + -------------------------- Convert to STG code ------------------------------- show_pass "Core2Stg" >> @@ -183,16 +182,9 @@ doIt (core_cmds, stg_cmds) let final_ids = collectFinalStgBinders (map fst stg_binds2) in - coreBindsSize tidy_binds `seq` --- TEMP: the above call zaps some space usage allocated by the --- simplifier, which for reasons I don't understand, persists --- thoroughout code generation - - ifaceDecls if_handle local_tycons local_classes inst_info - final_ids tidy_binds tidy_orphan_rules deprecations >> - endIface if_handle >> - -- We are definitely done w/ interface-file stuff at this point: - -- (See comments near call to "startIface".) + writeIface this_mod old_iface new_iface + local_tycons local_classes inst_info + final_ids tidy_binds tidy_orphan_rules >> -------------------------- Code generation ------------------------------- @@ -331,8 +323,8 @@ ppSourceStats short (HsModule name version 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 _ _ _ _ constrs derivs _ _) - = (length constrs, case derivs of {Nothing -> 0; Just ds -> length ds}) + data_info (TyData _ _ _ _ _ nconstrs derivs _ _) + = (nconstrs, case derivs of {Nothing -> 0; Just ds -> length ds}) data_info other = (0,0) class_info (ClassDecl _ _ _ _ meth_sigs def_meths _ _ _ _ _ _) diff --git a/ghc/compiler/main/MkIface.lhs b/ghc/compiler/main/MkIface.lhs index 50ebde3837..7370529ffa 100644 --- a/ghc/compiler/main/MkIface.lhs +++ b/ghc/compiler/main/MkIface.lhs @@ -4,9 +4,7 @@ \section[MkIface]{Print an interface for a module} \begin{code} -module MkIface ( - startIface, endIface, ifaceDecls - ) where +module MkIface ( writeIface ) where #include "HsVersions.h" @@ -14,8 +12,12 @@ import IO ( Handle, hPutStr, openFile, hClose, hPutStrLn, IOMode(..) ) import HsSyn -import BasicTypes ( Fixity(..), FixityDirection(..), NewOrData(..), - OccInfo, isLoopBreaker +import HsCore ( HsIdInfo(..), toUfExpr ) +import RdrHsSyn ( RdrNameRuleDecl ) +import HsPragmas ( DataPragmas(..), ClassPragmas(..) ) +import HsTypes ( toHsTyVars ) +import BasicTypes ( Fixity(..), FixityDirection(..), NewOrData(..), + Version, bumpVersion, initialVersion, isLoopBreaker ) import RnMonad import RnEnv ( availName ) @@ -29,24 +31,25 @@ import Id ( Id, idType, idInfo, omitIfaceSigForId, isUserExportedId, import Var ( isId ) import VarSet import DataCon ( StrictnessMark(..), dataConSig, dataConFieldLabels, dataConStrictMarks ) -import IdInfo ( IdInfo, StrictnessInfo(..), ArityInfo, InlinePragInfo(..), inlinePragInfo, - arityInfo, ppArityInfo, arityLowerBound, - strictnessInfo, ppStrictnessInfo, isBottomingStrictness, - cafInfo, ppCafInfo, specInfo, - cprInfo, ppCprInfo, pprInlinePragInfo, +import IdInfo ( IdInfo, StrictnessInfo(..), ArityInfo(..), InlinePragInfo(..), + CprInfo(..), CafInfo(..), + inlinePragInfo, arityInfo, arityLowerBound, + strictnessInfo, isBottomingStrictness, + cafInfo, specInfo, cprInfo, occInfo, isNeverInlinePrag, - workerExists, workerInfo, ppWorkerInfo, WorkerInfo(..) + workerExists, workerInfo, WorkerInfo(..) ) -import CoreSyn ( CoreExpr, CoreBind, Bind(..), rulesRules, rulesRhsFreeVars ) +import CoreSyn ( CoreExpr, CoreBind, Bind(..), isBuiltinRule, rulesRules, rulesRhsFreeVars ) import CoreFVs ( exprSomeFreeVars, ruleSomeLhsFreeVars, ruleSomeFreeVars ) import CoreUnfold ( okToUnfoldInHiFile, couldBeSmallEnoughToInline ) import Module ( moduleString, pprModule, pprModuleName ) -import Name ( isLocallyDefined, isWiredInName, nameRdrName, nameModule, +import RdrName ( RdrName ) +import Name ( isLocallyDefined, isWiredInName, toRdrName, nameModule, Name, NamedThing(..) ) import OccName ( OccName, pprOccName ) import TyCon ( TyCon, getSynTyConDefn, isSynTyCon, isNewTyCon, isAlgTyCon, - tyConTheta, tyConTyVars, tyConDataCons + tyConTheta, tyConTyVars, tyConDataCons, tyConFamilySize ) import Class ( Class, classExtraBigSig ) import FieldLabel ( fieldLabelName, fieldLabelType ) @@ -56,7 +59,6 @@ import Type ( mkSigmaTy, splitSigmaTy, mkDictTy, tidyTopType, ) import PprType -import PprCore ( pprIfaceUnfolding, pprCoreRule ) import FunDeps ( pprFundeps ) import Rules ( pprProtoCoreRule, ProtoCoreRule(..) ) @@ -66,222 +68,311 @@ import FiniteMap ( emptyFM, addToFM, addToFM_C, fmToList, FiniteMap ) import UniqFM ( lookupUFM, listToUFM ) import UniqSet ( uniqSetToList ) import Util ( sortLt, mapAccumL ) +import SrcLoc ( noSrcLoc ) import Bag import Outputable \end{code} -We have a function @startIface@ to open the output file and put -(something like) ``interface Foo'' in it. It gives back a handle -for subsequent additions to the interface file. -We then have one-function-per-block-of-interface-stuff, e.g., -@ifaceExportList@ produces the @__exports__@ section; it appends -to the handle provided by @startIface@. - -NOTE: ALWAYS remember that ghc-iface.lprl rewrites the interface file, -so you have to keep it in synch with the code below. Otherwise you'll -lose the happiest years of your life, believe me... -- SUP +%************************************************************************ +%* * +\subsection{Write a new interface file} +%* * +%************************************************************************ \begin{code} -startIface :: Module -> InterfaceDetails - -> IO (Maybe Handle) -- Nothing <=> don't do an interface +writeIface this_mod old_iface new_iface + local_tycons local_classes inst_info + final_ids tidy_binds tidy_orphan_rules + = case opt_ProduceHi of { + Nothing -> return () ; -- not producing any .hi file + + Just filename -> + + case checkIface old_iface full_new_iface of { + Nothing -> do { putStrLn "Interface file unchanged" ; + return () } ; -- No need to update .hi file + + Just final_iface -> + + do let mod_vers_unchanged = case old_iface of + Just iface -> pi_vers iface == pi_vers final_iface + Nothing -> False + if mod_vers_unchanged + then putStrLn "Module version unchanged, but usages differ; hence need new hi file" + else return () + + if_hdl <- openFile filename WriteMode + printForIface if_hdl (pprIface final_iface) + hClose if_hdl + }} + where + full_new_iface = completeIface new_iface local_tycons local_classes + inst_info final_ids tidy_binds + tidy_orphan_rules +\end{code} -ifaceDecls :: Maybe Handle - -> [TyCon] -> [Class] - -> Bag InstInfo - -> [Id] -- Ids used at code-gen time; they have better pragma info! - -> [CoreBind] -- In dependency order, later depend on earlier - -> [ProtoCoreRule] -- Rules - -> [Deprecation Name] - -> IO () -endIface :: Maybe Handle -> IO () -\end{code} +%************************************************************************ +%* * +\subsection{Checking if the new interface is up to date +%* * +%************************************************************************ \begin{code} -startIface mod (InterfaceDetails has_orphans import_usages (ExportEnv avails fixities _) _) - = case opt_ProduceHi of - Nothing -> return Nothing ; -- not producing any .hi file - - Just fn -> do - if_hdl <- openFile fn WriteMode - hPutStr if_hdl ("__interface \"" ++ show opt_InPackage ++ "\" " ++ moduleString mod) - hPutStr if_hdl (' ' : orphan_indicator) - hPutStrLn if_hdl " where" - ifaceExports if_hdl avails - ifaceImports if_hdl import_usages - ifaceFixities if_hdl fixities - return (Just if_hdl) +checkIface :: Maybe ParsedIface -- The old interface, read from M.hi + -> ParsedIface -- The new interface; but with all version numbers = 1 + -> Maybe ParsedIface -- Nothing => no change; no need to write new Iface + -- Just pi => 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 + +checkIface Nothing new_iface +-- No old interface, so definitely write a new one! + = Just new_iface + +checkIface (Just iface) new_iface + | no_output_change && no_usage_change + = Nothing + + | otherwise -- Add updated version numbers + = +{- pprTrace "checkIface" ( + vcat [ppr no_decl_changed <+> ppr no_export_change <+> ppr no_usage_change, + text "--------", + vcat (map ppr (pi_decls iface)), + text "--------", + vcat (map ppr (pi_decls new_iface)) + ]) $ +-} + Just (new_iface { pi_vers = new_mod_vers, + pi_fixity = (new_fixity_vers, new_fixities), + pi_rules = (new_rules_vers, new_rules), + pi_decls = final_decls + }) + where - orphan_indicator | has_orphans = " !" - | otherwise = "" + no_usage_change = pi_usages iface == pi_usages new_iface + + no_output_change = no_decl_changed && + new_fixity_vers == fixity_vers && + new_rules_vers == rules_vers && + no_export_change + + no_export_change = pi_exports iface == pi_exports new_iface + + new_mod_vers | no_output_change = mod_vers + | otherwise = bumpVersion mod_vers + + mod_vers = pi_vers iface + + (fixity_vers, fixities) = pi_fixity iface + (_, new_fixities) = pi_fixity new_iface + new_fixity_vers | fixities == new_fixities = fixity_vers + | otherwise = bumpVersion fixity_vers + + (rules_vers, rules) = pi_rules iface + (_, new_rules) = pi_rules new_iface + new_rules_vers | rules == new_rules = rules_vers + | otherwise = bumpVersion rules_vers + + (no_decl_changed, final_decls) = merge_decls True [] (pi_decls iface) (pi_decls new_iface) + + -- 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 + merge_decls ok_so_far acc [] [] = (ok_so_far, reverse acc) + merge_decls ok_so_far acc old [] = (False, reverse acc) + merge_decls ok_so_far acc [] (nvd:nvds) = merge_decls False (nvd:acc) [] nvds + merge_decls ok_so_far acc (vd@(v,d):vds) (nvd@(_,nd):nvds) + = case d_name `compare` nd_name of + LT -> merge_decls False acc vds (nvd:nvds) + GT -> merge_decls False (nvd:acc) (vd:vds) nvds + EQ | d == nd -> merge_decls ok_so_far (vd:acc) vds nvds + | otherwise -> merge_decls False ((bumpVersion v, nd):acc) vds nvds + where + d_name = hsDeclName d + nd_name = hsDeclName nd +\end{code} + + + +%************************************************************************ +%* * +\subsection{Printing the interface} +%* * +%************************************************************************ -endIface Nothing = return () -endIface (Just if_hdl) = hPutStr if_hdl "\n" >> hClose if_hdl +\begin{code} +pprIface (ParsedIface { pi_mod = mod, pi_vers = mod_vers, pi_orphan = orphan, + pi_usages = usages, pi_exports = exports, + pi_fixity = (fix_vers, fixities), + pi_insts = insts, pi_decls = decls, + pi_rules = (rule_vers, rules), pi_deprecs = deprecs }) + = vcat [ ptext SLIT("__interface") + <+> doubleQuotes (ptext opt_InPackage) + <+> ppr mod <+> ppr mod_vers <+> pp_sub_vers + <+> (if orphan then char '!' else empty) + <+> int opt_HiVersion + <+> ptext SLIT("where") + , vcat (map pprExport exports) + , vcat (map pprUsage usages) + , pprFixities fixities + , vcat [ppr i <+> semi | i <- insts] + , vcat [ppr_vers v <+> ppr d <> semi | (v,d) <- decls] + , pprRules rules + , pprDeprecs deprecs + ] + where + ppr_vers v | v == initialVersion = empty + | otherwise = int v + pp_sub_vers + | fix_vers == initialVersion && rule_vers == initialVersion = empty + | otherwise = brackets (ppr fix_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} -ifaceDecls Nothing tycons classes inst_info final_ids simplified rules _ = return () -ifaceDecls (Just hdl) - tycons classes - inst_infos - final_ids - binds - orphan_rules -- Rules defined locally for an Id that is *not* defined locally - deprecations - | null_decls = return () - -- You could have a module with just (re-)exports/instances in it - | otherwise - = ifaceClasses hdl classes >> - ifaceInstances hdl inst_infos >>= \ inst_ids -> - ifaceTyCons hdl tycons >> - ifaceBinds hdl (inst_ids `unionVarSet` orphan_rule_ids) - final_ids binds >>= \ emitted_ids -> - ifaceRules hdl orphan_rules emitted_ids >> - ifaceDeprecations hdl deprecations +pprExport :: ExportItem -> SDoc +pprExport (mod, items) + = hsep [ ptext SLIT("__export "), ppr mod, hsep (map upp_avail items) ] <> semi where - orphan_rule_ids = unionVarSets [ ruleSomeFreeVars interestingId rule - | ProtoCoreRule _ _ rule <- orphan_rules] - - null_decls = null binds && - null tycons && - null classes && - isEmptyBag inst_infos && - null orphan_rules && - null deprecations + upp_avail :: RdrAvailInfo -> SDoc + upp_avail (Avail name) = pprOccName name + upp_avail (AvailTC name []) = empty + upp_avail (AvailTC name ns) = hcat [pprOccName name, bang, upp_export ns'] + where + bang | name `elem` ns = empty + | otherwise = char '|' + ns' = filter (/= name) ns + + upp_export [] = empty + upp_export names = braces (hsep (map pprOccName names)) \end{code} + \begin{code} -ifaceImports :: Handle -> VersionInfo Name -> IO () -ifaceImports if_hdl import_usages - = hPutCol if_hdl upp_uses (sortLt lt_imp_vers import_usages) +pprUsage :: ImportVersion OccName -> SDoc +pprUsage (m, has_orphans, is_boot, whats_imported) + = hsep [ptext SLIT("import"), pprModuleName m, + pp_orphan, pp_boot, + upp_import_versions whats_imported + ] <> semi where - upp_uses (m, mv, has_orphans, is_boot, whats_imported) - = hsep [ptext SLIT("import"), pprModuleName m, - int mv, pp_orphan, pp_boot, - upp_import_versions whats_imported - ] <> semi - where - pp_orphan | has_orphans = ptext SLIT("!") - | otherwise = empty - pp_boot | is_boot = ptext SLIT("@") - | otherwise = empty + pp_orphan | has_orphans = char '!' + | otherwise = empty + pp_boot | is_boot = char '@' + | otherwise = empty -- Importing the whole module is indicated by an empty list - upp_import_versions Everything = empty - - -- For imported versions we do print the version number - upp_import_versions (Specifically nvs) - = dcolon <+> hsep [ hsep [ppr_unqual_name n, int v] | (n,v) <- sort_versions nvs ] - -{- SUP: What's this?? -ifaceModuleDeps if_hdl [] = return () -ifaceModuleDeps if_hdl mod_deps - = let - lines = map ppr_mod_dep mod_deps - ppr_mod_dep (mod, contains_orphans) - | contains_orphans = pprModuleName mod <+> ptext SLIT("!") - | otherwise = pprModuleName mod - in - printForIface if_hdl (ptext SLIT("__depends") <+> vcat lines <> ptext SLIT(" ;")) >> - hPutStr if_hdl "\n" --} + upp_import_versions NothingAtAll = empty + upp_import_versions (Everything v) = dcolon <+> int v + upp_import_versions (Specifically vm vf vr nvs) + = dcolon <+> int vm <+> int vf <+> int vr <+> hsep [ ppr n <+> int v | (n,v) <- nvs ] +\end{code} -ifaceExports :: Handle -> Avails -> IO () -ifaceExports if_hdl [] = return () -ifaceExports if_hdl avails - = hPutCol if_hdl do_one_module (fmToList export_fm) - where - -- Sort them into groups by module - export_fm :: FiniteMap Module [AvailInfo] - export_fm = foldr insert emptyFM avails - - insert avail efm = addToFM_C (++) efm mod [avail] - where - mod = nameModule (availName avail) - - -- Print one module's worth of stuff - do_one_module :: (Module, [AvailInfo]) -> SDoc - do_one_module (mod_name, avails@(avail1:_)) - = ptext SLIT("__export ") <> - hsep [pprModule mod_name, - hsep (map upp_avail (sortLt lt_avail avails)) - ] <> semi - -ifaceFixities :: Handle -> Fixities -> IO () -ifaceFixities if_hdl [] = return () -ifaceFixities if_hdl fixities - = hPutCol if_hdl upp_fixity fixities - -ifaceRules :: Handle -> [ProtoCoreRule] -> IdSet -> IO () -ifaceRules if_hdl rules emitted - | opt_OmitInterfacePragmas -- Don't emit rules if we are suppressing - -- interface pragmas - || (null orphan_rule_pretties && null local_id_pretties) - = return () - | otherwise - = printForIface if_hdl (vcat [ - ptext SLIT("{-## __R"), - vcat orphan_rule_pretties, - vcat local_id_pretties, - ptext SLIT("##-}") - ]) - where - orphan_rule_pretties = [ pprCoreRule (Just fn) rule - | ProtoCoreRule _ fn rule <- rules - ] - local_id_pretties = [ pprCoreRule (Just fn) rule - | fn <- varSetElems emitted, - rule <- rulesRules (idSpecialisation fn), - all (`elemVarSet` emitted) (varSetElems (ruleSomeLhsFreeVars interestingId rule)) - -- Spit out a rule only if all its lhs free vars are emitted - -- This is a good reason not to do it when we emit the Id itself - ] - -ifaceDeprecations :: Handle -> [Deprecation Name] -> IO () -ifaceDeprecations if_hdl [] = return () -ifaceDeprecations if_hdl deprecations - = printForIface if_hdl (vcat [ - ptext SLIT("{-## __D"), - vcat [ pprIE ie <+> doubleQuotes (ppr txt) <> semi | Deprecation ie txt <- deprecations ], - ptext SLIT("##-}") - ]) + +\begin{code} +pprFixities [] = empty +pprFixities fixes = hsep (map ppr fixes) <> semi + +pprRules [] = empty +pprRules rules = hsep [ptext SLIT("{-## __R"), hsep (map ppr rules), ptext SLIT("##-}")] + +pprDeprecs [] = empty +pprDeprecs deps = hsep [ ptext SLIT("{-## __D"), guts, ptext SLIT("##-}")] + where + guts = hsep [ ppr ie <+> doubleQuotes (ppr txt) <> semi + | Deprecation ie txt _ <- deps ] +\end{code} + + +%************************************************************************ +%* * +\subsection{Completing the new interface} +%* * +%************************************************************************ + +\begin{code} +completeIface new_iface local_tycons local_classes + inst_info final_ids tidy_binds + tidy_orphan_rules + = new_iface { pi_decls = [(initialVersion,d) | d <- sortLt lt_decl all_decls], + pi_insts = sortLt lt_inst_decl inst_dcls, + pi_rules = (initialVersion, rule_dcls) + } where - pprIE (IEVar n ) = ppr n - pprIE (IEThingAbs n ) = ppr n - pprIE (IEThingAll n ) = hcat [ppr n, text "(..)"] - pprIE (IEThingWith n ns) = ppr n <> parens (hcat (punctuate comma (map ppr ns))) - pprIE (IEModuleContents _ ) = empty + all_decls = cls_dcls ++ ty_dcls ++ bagToList val_dcls + (inst_dcls, inst_ids) = ifaceInstances inst_info + cls_dcls = map ifaceClass local_classes + ty_dcls = map ifaceTyCon (filter (not . isWiredInName . getName) local_tycons) + + (val_dcls, emitted_ids) = ifaceBinds (inst_ids `unionVarSet` orphan_rule_ids) + final_ids tidy_binds + + rule_dcls | opt_OmitInterfacePragmas = [] + | otherwise = ifaceRules tidy_orphan_rules emitted_ids + + orphan_rule_ids = unionVarSets [ ruleSomeFreeVars interestingId rule + | ProtoCoreRule _ _ rule <- tidy_orphan_rules] + +lt_inst_decl (InstDecl _ _ _ dfun_id1 _) (InstDecl _ _ _ dfun_id2 _) + = dfun_id1 < dfun_id2 + -- The dfuns are assigned names df1, df2, etc, + -- in order of original textual + -- occurrence, and this makes as good a sort order as any + +lt_decl d1 d2 = hsDeclName d1 < hsDeclName d2 \end{code} + %************************************************************************ %* * -\subsection{Instance declarations} +\subsection{Completion stuff} %* * %************************************************************************ +\begin{code} +ifaceRules :: [ProtoCoreRule] -> IdSet -> [RdrNameRuleDecl] +ifaceRules rules emitted + = orphan_rules ++ local_rules + where + orphan_rules = [ toHsRule fn rule | ProtoCoreRule _ fn rule <- rules ] + local_rules = [ toHsRule fn rule + | fn <- varSetElems emitted, + rule <- rulesRules (idSpecialisation fn), + not (isBuiltinRule rule), + -- We can't print builtin rules in interface files + -- Since they are built in, an importing module + -- will have access to them anyway + all (`elemVarSet` emitted) (varSetElems (ruleSomeLhsFreeVars interestingId rule)) + -- Spit out a rule only if all its lhs free vars are emitted + -- This is a good reason not to do it when we emit the Id itself + ] +\end{code} \begin{code} -ifaceInstances :: Handle -> Bag InstInfo -> IO IdSet -- The IdSet is the needed dfuns -ifaceInstances if_hdl inst_infos - | null togo_insts = return emptyVarSet - | otherwise = hPutCol if_hdl pp_inst (sortLt lt_inst togo_insts) >> - return needed_ids - where +ifaceInstances :: Bag InstInfo -> ([RdrNameInstDecl], IdSet) + -- The IdSet is the needed dfuns + +ifaceInstances inst_infos + = (decls, needed_ids) + where + decls = map to_decl togo_insts togo_insts = filter is_togo_inst (bagToList inst_infos) needed_ids = mkVarSet [dfun_id | InstInfo _ _ _ _ dfun_id _ _ _ <- togo_insts] is_togo_inst (InstInfo _ _ _ _ dfun_id _ _ _) = isLocallyDefined dfun_id ------- - lt_inst (InstInfo _ _ _ _ dfun_id1 _ _ _) - (InstInfo _ _ _ _ dfun_id2 _ _ _) - = getOccName dfun_id1 < getOccName dfun_id2 - -- The dfuns are assigned names df1, df2, etc, in order of original textual - -- occurrence, and this makes as good a sort order as any - - ------- - pp_inst (InstInfo clas tvs tys theta dfun_id _ _ _) + to_decl (InstInfo clas tvs tys theta dfun_id _ _ _) = let -- The deNoteType is very important. It removes all type -- synonyms from the instance type in interface files. @@ -294,88 +385,217 @@ ifaceInstances if_hdl inst_infos -- that mentioned T but not Tibble. forall_ty = mkSigmaTy tvs (classesToPreds theta) (deNoteType (mkDictTy clas tys)) - renumbered_ty = tidyTopType forall_ty + tidy_ty = tidyTopType forall_ty in - hcat [ptext SLIT("instance "), pprType renumbered_ty, - ptext SLIT(" = "), ppr_unqual_name dfun_id, semi] + InstDecl (toHsType tidy_ty) EmptyMonoBinds [] (toRdrName dfun_id) noSrcLoc +\end{code} + +\begin{code} +ifaceTyCon :: TyCon -> RdrNameHsDecl +ifaceTyCon tycon + | isSynTyCon tycon + = TyClD (TySynonym (toRdrName tycon) + (toHsTyVars tyvars) (toHsType ty) + noSrcLoc) + where + (tyvars, ty) = getSynTyConDefn tycon + +ifaceTyCon tycon + | isAlgTyCon tycon + = TyClD (TyData new_or_data (toHsContext (tyConTheta tycon)) + (toRdrName tycon) + (toHsTyVars tyvars) + (map ifaceConDecl (tyConDataCons tycon)) + (tyConFamilySize tycon) + Nothing NoDataPragmas noSrcLoc) + where + tyvars = tyConTyVars tycon + new_or_data | isNewTyCon tycon = NewType + | otherwise = DataType + + ifaceConDecl data_con + = ConDecl (toRdrName data_con) (error "ifaceConDecl") + (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 = dataConStrictMarks data_con + details + | null field_labels + = ASSERT( tycon == tycon1 && tyvars == tyvars1 ) + VanillaCon (zipWith mk_bang_ty strict_marks arg_tys) + + | otherwise + = RecCon (zipWith mk_field strict_marks field_labels) + + mk_bang_ty NotMarkedStrict ty = Unbanged (toHsType ty) + mk_bang_ty (MarkedUnboxed _ _) ty = Unpacked (toHsType ty) + mk_bang_ty MarkedStrict ty = Banged (toHsType ty) + + mk_field strict_mark field_label + = ([toRdrName field_label], mk_bang_ty strict_mark (fieldLabelType field_label)) + +ifaceTyCon tycon + = pprPanic "pprIfaceTyDecl" (ppr tycon) + +ifaceClass clas + = TyClD (ClassDecl (toHsContext sc_theta) + (toRdrName clas) + (toHsTyVars clas_tyvars) + (toHsFDs clas_fds) + (map toClassOpSig op_stuff) + EmptyMonoBinds NoClassPragmas + bogus bogus bogus [] noSrcLoc + ) + where + bogus = error "ifaceClass" + (clas_tyvars, clas_fds, sc_theta, _, op_stuff) = classExtraBigSig clas + + toClassOpSig (sel_id, dm_id, explicit_dm) + = ASSERT( sel_tyvars == clas_tyvars) + ClassOpSig (toRdrName sel_id) bogus explicit_dm (toHsType op_ty) noSrcLoc + where + (sel_tyvars, _, op_ty) = splitSigmaTy (idType sel_id) \end{code} %************************************************************************ %* * -\subsection{Printing values} +\subsection{Value bindings} %* * %************************************************************************ \begin{code} -ifaceId :: (Id -> IdInfo) -- This function "knows" the extra info added - -- by the STG passes. Sigh +ifaceBinds :: IdSet -- These Ids are needed already + -> [Id] -- Ids used at code-gen time; they have better pragma info! + -> [CoreBind] -- In dependency order, later depend on earlier + -> (Bag RdrNameHsDecl, IdSet) -- Set of Ids actually spat out + +ifaceBinds needed_ids final_ids binds + = go needed_ids (reverse binds) emptyBag emptyVarSet + -- Reverse so that later things will + -- provoke earlier ones to be emitted + where + final_id_map = listToUFM [(id,id) | id <- final_ids] + get_idinfo id = case lookupUFM final_id_map id of + Just id' -> idInfo id' + Nothing -> pprTrace "ifaceBinds not found:" (ppr id) $ + idInfo id - -> IdSet -- Set of Ids that are needed by earlier interface - -- file emissions. If the Id isn't in this set, and isn't - -- exported, there's no need to emit anything - -> Bool -- True <=> recursive, so don't print unfolding - -> Id - -> CoreExpr -- The Id's right hand side - -> Maybe (SDoc, IdSet) -- The emitted stuff, plus any *extra* needed Ids + go needed [] decls emitted + | not (isEmptyVarSet needed) = pprTrace "ifaceBinds: free vars:" + (sep (map ppr (varSetElems needed))) + (decls, emitted) + | otherwise = (decls, emitted) + + go needed (NonRec id rhs : binds) decls emitted + = case ifaceId get_idinfo needed False id rhs of + Nothing -> go needed binds decls emitted + Just (decl, extras) -> let + needed' = (needed `unionVarSet` extras) `delVarSet` id + -- 'extras' can include the Id itself via a rule + emitted' = emitted `extendVarSet` id + in + go needed' binds (decl `consBag` decls) emitted' + + -- Recursive groups are a bit more of a pain. We may only need one to + -- start with, but it may call out the next one, and so on. So we + -- have to look for a fixed point. + go needed (Rec pairs : binds) decls emitted + = go needed' binds decls' emitted' + where + (new_decls, new_emitted, extras) = go_rec needed pairs + decls' = new_decls `unionBags` decls + needed' = (needed `unionVarSet` extras) `minusVarSet` mkVarSet (map fst pairs) + emitted' = emitted `unionVarSet` new_emitted + + go_rec :: IdSet -> [(Id,CoreExpr)] -> (Bag RdrNameHsDecl, IdSet, IdSet) + go_rec needed pairs + | null decls = (emptyBag, emptyVarSet, emptyVarSet) + | otherwise = (more_decls `unionBags` listToBag decls, + more_emitted `unionVarSet` mkVarSet emitted, + more_extras `unionVarSet` extras) + where + maybes = map do_one pairs + emitted = [id | ((id,_), Just _) <- pairs `zip` maybes] + reduced_pairs = [pair | (pair, Nothing) <- pairs `zip` maybes] + (decls, extras_s) = unzip (catMaybes maybes) + extras = unionVarSets extras_s + (more_decls, more_emitted, more_extras) = go_rec extras reduced_pairs + + do_one (id,rhs) = ifaceId get_idinfo needed True id rhs +\end{code} + + +\begin{code} +ifaceId :: (Id -> IdInfo) -- This function "knows" the extra info added + -- by the STG passes. Sigh + + -> IdSet -- Set of Ids that are needed by earlier interface + -- file emissions. If the Id isn't in this set, and isn't + -- exported, there's no need to emit anything + -> Bool -- True <=> recursive, so don't print unfolding + -> Id + -> CoreExpr -- The Id's right hand side + -> Maybe (RdrNameHsDecl, IdSet) -- The emitted stuff, plus any *extra* needed Ids ifaceId get_idinfo needed_ids is_rec id rhs | not (id `elemVarSet` needed_ids || -- Needed [no id in needed_ids has omitIfaceSigForId] - (isUserExportedId id && not (omitIfaceSigForId id))) -- or exported and not to be omitted + (isUserExportedId id && not (omitIfaceSigForId id))) -- or exported and not to be omitted = Nothing -- Well, that was easy! ifaceId get_idinfo needed_ids is_rec id rhs = ASSERT2( arity_matches_strictness, ppr id ) - Just (hsep [sig_pretty, prag_pretty, char ';'], new_needed_ids) + Just (SigD (IfaceSig (toRdrName id) (toHsType id_type) hs_idinfo noSrcLoc), + new_needed_ids) where + id_type = idType id core_idinfo = idInfo id stg_idinfo = get_idinfo id - ty_pretty = pprType (idType id) - sig_pretty = hsep [ppr (getOccName id), dcolon, ty_pretty] - - prag_pretty - | opt_OmitInterfacePragmas = empty - | otherwise = hsep [ptext SLIT("{-##"), - arity_pretty, - caf_pretty, - cpr_pretty, - strict_pretty, - wrkr_pretty, - unfold_pretty, - ptext SLIT("##-}")] + hs_idinfo | opt_OmitInterfacePragmas = [] + | otherwise = arity_hsinfo ++ caf_hsinfo ++ cpr_hsinfo ++ + strict_hsinfo ++ wrkr_hsinfo ++ unfold_hsinfo ------------ Arity -------------- - arity_info = arityInfo stg_idinfo - arity_pretty = ppArityInfo arity_info + arity_info = arityInfo stg_idinfo + arity_hsinfo = case arityInfo stg_idinfo of + a@(ArityExactly n) -> [HsArity a] + other -> [] ------------ Caf Info -------------- - caf_pretty = ppCafInfo (cafInfo stg_idinfo) + caf_hsinfo = case cafInfo stg_idinfo of + NoCafRefs -> [HsNoCafRefs] + otherwise -> [] ------------ CPR Info -------------- - cpr_pretty = ppCprInfo (cprInfo core_idinfo) + cpr_hsinfo = case cprInfo core_idinfo of + ReturnsCPR -> [HsCprInfo] + NoCPRInfo -> [] ------------ Strictness -------------- strict_info = strictnessInfo core_idinfo bottoming_fn = isBottomingStrictness strict_info - strict_pretty = ppStrictnessInfo strict_info + strict_hsinfo = case strict_info of + NoStrictnessInfo -> [] + info -> [HsStrictness info] + ------------ Worker -------------- work_info = workerInfo core_idinfo has_worker = workerExists work_info - wrkr_pretty = ppWorkerInfo work_info - HasWorker work_id wrap_arity = work_info - - - ------------ Occ info -------------- - loop_breaker = isLoopBreaker (occInfo core_idinfo) + wrkr_hsinfo = case work_info of + HasWorker work_id _ -> [HsWorker (toRdrName work_id)] + other -> [] ------------ Unfolding -------------- inline_pragma = inlinePragInfo core_idinfo dont_inline = isNeverInlinePrag inline_pragma - unfold_pretty | show_unfold = ptext SLIT("__U") <> pprInlinePragInfo inline_pragma <+> pprIfaceUnfolding rhs - | otherwise = empty + unfold_hsinfo | show_unfold = [HsUnfold inline_pragma (toUfExpr rhs)] + | otherwise = [] show_unfold = not has_worker && -- Not unnecessary not bottoming_fn && -- Not necessary @@ -389,16 +609,20 @@ ifaceId get_idinfo needed_ids is_rec id rhs ------------ Specialisations -------------- spec_info = specInfo core_idinfo + ------------ Occ info -------------- + loop_breaker = isLoopBreaker (occInfo core_idinfo) + ------------ Extra free Ids -------------- new_needed_ids | opt_OmitInterfacePragmas = emptyVarSet | otherwise = worker_ids `unionVarSet` unfold_ids `unionVarSet` spec_ids - worker_ids | has_worker && interestingId work_id = unitVarSet work_id + worker_ids = case work_info of + HasWorker work_id _ | interestingId work_id -> unitVarSet work_id -- Conceivably, the worker might come from -- another module - | otherwise = emptyVarSet + other -> emptyVarSet spec_ids = filterVarSet interestingId (rulesRhsFreeVars spec_info) @@ -410,289 +634,12 @@ ifaceId get_idinfo needed_ids is_rec id rhs ------------ Sanity checking -------------- -- The arity of a wrapper function should match its strictness, -- or else an importing module will get very confused indeed. - arity_matches_strictness = not has_worker || - wrap_arity == arityLowerBound arity_info + arity_matches_strictness + = case work_info of + HasWorker _ wrap_arity -> wrap_arity == arityLowerBound arity_info + other -> True interestingId id = isId id && isLocallyDefined id && not (omitIfaceSigForId id) \end{code} -\begin{code} -ifaceBinds :: Handle - -> IdSet -- These Ids are needed already - -> [Id] -- Ids used at code-gen time; they have better pragma info! - -> [CoreBind] -- In dependency order, later depend on earlier - -> IO IdSet -- Set of Ids actually spat out - -ifaceBinds hdl needed_ids final_ids binds - = mapIO (printForIface hdl) (bagToList pretties) >> - hPutStr hdl "\n" >> - return emitted - where - final_id_map = listToUFM [(id,id) | id <- final_ids] - get_idinfo id = case lookupUFM final_id_map id of - Just id' -> idInfo id' - Nothing -> pprTrace "ifaceBinds not found:" (ppr id) $ - idInfo id - - (pretties, emitted) = go needed_ids (reverse binds) emptyBag emptyVarSet - -- Reverse so that later things will - -- provoke earlier ones to be emitted - go needed [] pretties emitted - | not (isEmptyVarSet needed) = pprTrace "ifaceBinds: free vars:" - (sep (map ppr (varSetElems needed))) - (pretties, emitted) - | otherwise = (pretties, emitted) - - go needed (NonRec id rhs : binds) pretties emitted - = case ifaceId get_idinfo needed False id rhs of - Nothing -> go needed binds pretties emitted - Just (pretty, extras) -> let - needed' = (needed `unionVarSet` extras) `delVarSet` id - -- 'extras' can include the Id itself via a rule - emitted' = emitted `extendVarSet` id - in - go needed' binds (pretty `consBag` pretties) emitted' - - -- Recursive groups are a bit more of a pain. We may only need one to - -- start with, but it may call out the next one, and so on. So we - -- have to look for a fixed point. - go needed (Rec pairs : binds) pretties emitted - = go needed' binds pretties' emitted' - where - (new_pretties, new_emitted, extras) = go_rec needed pairs - pretties' = new_pretties `unionBags` pretties - needed' = (needed `unionVarSet` extras) `minusVarSet` mkVarSet (map fst pairs) - emitted' = emitted `unionVarSet` new_emitted - - go_rec :: IdSet -> [(Id,CoreExpr)] -> (Bag SDoc, IdSet, IdSet) - go_rec needed pairs - | null pretties = (emptyBag, emptyVarSet, emptyVarSet) - | otherwise = (more_pretties `unionBags` listToBag pretties, - more_emitted `unionVarSet` mkVarSet emitted, - more_extras `unionVarSet` extras) - where - maybes = map do_one pairs - emitted = [id | ((id,_), Just _) <- pairs `zip` maybes] - reduced_pairs = [pair | (pair, Nothing) <- pairs `zip` maybes] - (pretties, extras_s) = unzip (catMaybes maybes) - extras = unionVarSets extras_s - (more_pretties, more_emitted, more_extras) = go_rec extras reduced_pairs - - do_one (id,rhs) = ifaceId get_idinfo needed True id rhs -\end{code} - - -%************************************************************************ -%* * -\subsection{Random small things} -%* * -%************************************************************************ - -\begin{code} -ifaceTyCons hdl tycons = hPutCol hdl upp_tycon (sortLt (<) (filter (for_iface_name . getName) tycons)) -ifaceClasses hdl classes = hPutCol hdl upp_class (sortLt (<) (filter (for_iface_name . getName) classes)) - -for_iface_name name = isLocallyDefined name && - not (isWiredInName name) - -upp_tycon tycon = ifaceTyCon tycon -upp_class clas = ifaceClass clas -\end{code} - - -\begin{code} -ifaceTyCon :: TyCon -> SDoc -ifaceTyCon tycon - | isSynTyCon tycon - = hsep [ ptext SLIT("type"), - ppr (getName tycon), - pprTyVarBndrs tyvars, - ptext SLIT("="), - ppr ty, - semi - ] - where - (tyvars, ty) = getSynTyConDefn tycon - -ifaceTyCon tycon - | isAlgTyCon tycon - = hsep [ ptext keyword, - ppr_decl_class_context (tyConTheta tycon), - ppr (getName tycon), - pprTyVarBndrs (tyConTyVars tycon), - ptext SLIT("="), - hsep (punctuate (ptext SLIT(" | ")) (map ppr_con (tyConDataCons tycon))), - semi - ] - where - keyword | isNewTyCon tycon = SLIT("newtype") - | otherwise = SLIT("data") - - tyvars = tyConTyVars tycon - - ppr_con data_con - | null field_labels - = ASSERT( tycon == tycon1 && tyvars == tyvars1 ) - hsep [ ppr_ex ex_tyvars ex_theta, - ppr name, - hsep (map ppr_arg_ty (strict_marks `zip` arg_tys)) - ] - - | otherwise - = hsep [ ppr_ex ex_tyvars ex_theta, - ppr name, - braces $ hsep $ punctuate comma (map ppr_field (strict_marks `zip` field_labels)) - ] - where - (tyvars1, _, ex_tyvars, ex_theta, arg_tys, tycon1) = dataConSig data_con - field_labels = dataConFieldLabels data_con - strict_marks = dataConStrictMarks data_con - name = getName data_con - - ppr_ex [] ex_theta = ASSERT( null ex_theta ) empty - ppr_ex ex_tvs ex_theta = ptext SLIT("__forall") <+> brackets (pprTyVarBndrs ex_tvs) - <+> pprIfaceClasses ex_theta <+> ptext SLIT("=>") - - ppr_arg_ty (strict_mark, ty) = ppr_strict_mark strict_mark <> pprParendType ty - - ppr_strict_mark NotMarkedStrict = empty - ppr_strict_mark (MarkedUnboxed _ _) = ptext SLIT("! ! ") - ppr_strict_mark MarkedStrict = ptext SLIT("! ") - - ppr_field (strict_mark, field_label) - = hsep [ ppr (fieldLabelName field_label), - dcolon, - ppr_strict_mark strict_mark <> pprParendType (fieldLabelType field_label) - ] - -ifaceTyCon tycon - = pprPanic "pprIfaceTyDecl" (ppr tycon) - -ifaceClass clas - = hsep [ptext SLIT("class"), - ppr_decl_class_context sc_theta, - ppr clas, -- Print the name - pprTyVarBndrs clas_tyvars, - pprFundeps clas_fds, - pp_ops, - semi - ] - where - (clas_tyvars, clas_fds, sc_theta, _, op_stuff) = classExtraBigSig clas - - pp_ops | null op_stuff = empty - | otherwise = hsep [ptext SLIT("where"), - braces (hsep (punctuate semi (map ppr_classop op_stuff))) - ] - - ppr_classop (sel_id, dm_id, explicit_dm) - = ASSERT( sel_tyvars == clas_tyvars) - hsep [ppr (getOccName sel_id), - if explicit_dm then equals else empty, - dcolon, - ppr op_ty - ] - where - (sel_tyvars, _, op_ty) = splitSigmaTy (idType sel_id) - -ppr_decl_context :: ThetaType -> SDoc -ppr_decl_context [] = empty -ppr_decl_context theta = pprIfaceTheta theta <+> ptext SLIT(" =>") - -ppr_decl_class_context :: ClassContext -> SDoc -ppr_decl_class_context [] = empty -ppr_decl_class_context ctxt = pprIfaceClasses ctxt <+> ptext SLIT(" =>") - -pprIfaceTheta :: ThetaType -> SDoc -- Use braces rather than parens in interface files -pprIfaceTheta [] = empty -pprIfaceTheta theta = braces (hsep (punctuate comma [pprIfacePred p | p <- theta])) - --- ZZ - not sure who uses this - i.e. whether IParams really show up or not --- (it's not used to print normal value signatures) -pprIfacePred :: PredType -> SDoc -pprIfacePred (Class clas tys) = pprConstraint clas tys -pprIfacePred (IParam n ty) = char '?' <> ppr n <+> ptext SLIT("::") <+> ppr ty - -pprIfaceClasses :: ClassContext -> SDoc -pprIfaceClasses [] = empty -pprIfaceClasses theta = braces (hsep (punctuate comma [pprConstraint c tys | (c,tys) <- theta])) -\end{code} - -%************************************************************************ -%* * -\subsection{Random small things} -%* * -%************************************************************************ - -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} -upp_avail :: AvailInfo -> SDoc -upp_avail (Avail name) = pprOccName (getOccName name) -upp_avail (AvailTC name []) = empty -upp_avail (AvailTC name ns) = hcat [pprOccName (getOccName name), bang, upp_export ns'] - where - bang | name `elem` ns = empty - | otherwise = char '|' - ns' = filter (/= name) ns - -upp_export :: [Name] -> SDoc -upp_export [] = empty -upp_export names = braces (hsep (map (pprOccName . getOccName) names)) - -upp_fixity :: (Name, Fixity) -> SDoc -upp_fixity (name, fixity) = hsep [ptext SLIT("0"), ppr fixity, ppr name, semi] - -- Dummy version number! - -ppr_unqual_name :: NamedThing a => a -> SDoc -- Just its occurrence name -ppr_unqual_name name = pprOccName (getOccName name) -\end{code} - - -%************************************************************************ -%* * -\subsection{Comparisons} -%* * -%************************************************************************ - - -The various sorts above simply prevent unnecessary "wobbling" when -things change that don't have to. We therefore compare lexically, not -by unique - -\begin{code} -lt_avail :: AvailInfo -> AvailInfo -> Bool - -a1 `lt_avail` a2 = availName a1 `lt_name` availName a2 - -lt_name :: Name -> Name -> Bool -n1 `lt_name` n2 = nameRdrName n1 < nameRdrName n2 - -lt_lexical :: NamedThing a => a -> a -> Bool -lt_lexical a1 a2 = getName a1 `lt_name` getName a2 - -lt_imp_vers :: ImportVersion a -> ImportVersion a -> Bool -lt_imp_vers (m1,_,_,_,_) (m2,_,_,_,_) = m1 < m2 - -sort_versions vs = sortLt lt_vers vs - -lt_vers :: LocalVersion Name -> LocalVersion Name -> Bool -lt_vers (n1,v1) (n2,v2) = n1 `lt_name` n2 -\end{code} - - -\begin{code} -hPutCol :: Handle - -> (a -> SDoc) - -> [a] - -> IO () -hPutCol hdl fmt xs = mapIO (printForIface hdl . fmt) xs - -mapIO :: (a -> IO b) -> [a] -> IO () -mapIO f [] = return () -mapIO f (x:xs) = f x >> mapIO f xs -\end{code} diff --git a/ghc/compiler/parser/Lex.lhs b/ghc/compiler/parser/Lex.lhs index 0a247e0d03..4283c328dc 100644 --- a/ghc/compiler/parser/Lex.lhs +++ b/ghc/compiler/parser/Lex.lhs @@ -38,11 +38,11 @@ import List ( isSuffixOf ) import IdInfo ( InlinePragInfo(..), CprInfo(..) ) import Name ( isLowerISO, isUpperISO ) -import PrelMods ( mkTupNameStr, mkUbxTupNameStr ) +import PrelNames ( mkTupNameStr ) import CmdLineOpts ( opt_IgnoreIfacePragmas, opt_HiVersion, opt_NoHiCheck ) import Demand ( Demand(..) {- instance Read -} ) import UniqFM ( UniqFM, listToUFM, lookupUFM) -import BasicTypes ( NewOrData(..) ) +import BasicTypes ( NewOrData(..), Boxity(..) ) import SrcLoc ( SrcLoc, incSrcLine, srcLocFile, srcLocLine, replaceSrcLine, mkSrcLoc ) @@ -1018,7 +1018,7 @@ lex_tuple cont mod buf back_off = go n buf = case currentChar# buf of ','# -> go (n+1) (stepOn buf) - ')'# -> cont (ITqconid (mod, snd (mkTupNameStr n))) (stepOn buf) + ')'# -> cont (ITqconid (mod, snd (mkTupNameStr Boxed n))) (stepOn buf) _ -> back_off lex_ubx_tuple cont mod buf back_off = @@ -1028,7 +1028,7 @@ lex_ubx_tuple cont mod buf back_off = case currentChar# buf of ','# -> go (n+1) (stepOn buf) '#'# -> case lookAhead# buf 1# of - ')'# -> cont (ITqconid (mod, snd (mkUbxTupNameStr n))) + ')'# -> cont (ITqconid (mod, snd (mkTupNameStr Unboxed n))) (stepOnBy# buf 2#) _ -> back_off _ -> back_off diff --git a/ghc/compiler/parser/ParseUtil.lhs b/ghc/compiler/parser/ParseUtil.lhs index 93aa715702..3e7cafe184 100644 --- a/ghc/compiler/parser/ParseUtil.lhs +++ b/ghc/compiler/parser/ParseUtil.lhs @@ -18,7 +18,6 @@ module ParseUtil ( , checkPrec -- String -> P String , checkContext -- HsType -> P HsContext , checkInstType -- HsType -> P HsType - , checkAssertion -- HsType -> P HsAsst , checkDataHeader -- HsQualType -> P (HsContext,HsName,[HsName]) , checkSimple -- HsType -> [HsName] -> P ((HsName,[HsName])) , checkPattern -- HsExp -> P HsPat @@ -54,11 +53,12 @@ import SrcLoc import RdrHsSyn import RdrName import CallConv -import PrelMods ( pRELUDE_Name, mkUbxTupNameStr, mkTupNameStr ) +import PrelNames ( pRELUDE_Name, mkTupNameStr ) import OccName ( dataName, tcName, varName, tvName, setOccNameSpace, occNameUserString ) import CmdLineOpts ( opt_NoImplicitPrelude ) import StringBuffer ( lexemeToString ) import FastString ( unpackFS ) +import BasicTypes ( Boxity(..) ) import ErrUtils import UniqFM ( UniqFM, listToUFM, lookupUFM ) import Outputable @@ -86,9 +86,9 @@ splitForConApp :: RdrNameHsType -> [RdrNameBangType] splitForConApp t ts = split t ts where - split (MonoTyApp t u) ts = split t (Unbanged u : ts) + split (HsAppTy t u) ts = split t (Unbanged u : ts) - split (MonoTyVar t) ts = returnP (con, ts) + split (HsTyVar t) ts = returnP (con, ts) where t_occ = rdrNameOcc t con = setRdrNameOcc t (setOccNameSpace t_occ dataName) @@ -117,17 +117,17 @@ checkInstType :: RdrNameHsType -> P RdrNameHsType checkInstType t = case t of HsForAllTy tvs ctxt ty -> - checkAssertion ty [] `thenP` \(c,ts)-> - returnP (HsForAllTy tvs ctxt (MonoDictTy c ts)) + checkDictTy ty [] `thenP` \ dict_ty -> + returnP (HsForAllTy tvs ctxt dict_ty) - ty -> checkAssertion ty [] `thenP` \(c,ts)-> - returnP (HsForAllTy Nothing [] (MonoDictTy c ts)) + ty -> checkDictTy ty [] `thenP` \ dict_ty-> + returnP (HsForAllTy Nothing [] dict_ty) checkContext :: RdrNameHsType -> P RdrNameContext -checkContext (MonoTupleTy ts True) +checkContext (HsTupleTy _ ts) = mapP (\t -> checkPred t []) ts `thenP` \ps -> returnP ps -checkContext (MonoTyVar t) -- empty contexts are allowed +checkContext (HsTyVar t) -- empty contexts are allowed | t == unitTyCon_RDR = returnP [] checkContext t = checkPred t [] `thenP` \p -> @@ -135,18 +135,17 @@ checkContext t checkPred :: RdrNameHsType -> [RdrNameHsType] -> P (HsPred RdrName) -checkPred (MonoTyVar t) args@(_:_) | not (isRdrTyVar t) +checkPred (HsTyVar t) args@(_:_) | not (isRdrTyVar t) = returnP (HsPClass t args) -checkPred (MonoTyApp l r) args = checkPred l (r:args) -checkPred (MonoIParamTy n ty) [] = returnP (HsPIParam n ty) +checkPred (HsAppTy l r) args = checkPred l (r:args) +checkPred (HsPredTy (HsPIParam n ty)) [] = returnP (HsPIParam n ty) checkPred _ _ = parseError "Illegal class assertion" -checkAssertion :: RdrNameHsType -> [RdrNameHsType] - -> P (HsClassAssertion RdrName) -checkAssertion (MonoTyVar t) args@(_:_) | not (isRdrTyVar t) - = returnP (t,args) -checkAssertion (MonoTyApp l r) args = checkAssertion l (r:args) -checkAssertion _ _ = parseError "Illegal class assertion" +checkDictTy :: RdrNameHsType -> [RdrNameHsType] -> P RdrNameHsType +checkDictTy (HsTyVar t) args@(_:_) | not (isRdrTyVar t) + = returnP (mkHsDictTy t args) +checkDictTy (HsAppTy l r) args = checkDictTy l (r:args) +checkDictTy _ _ = parseError "Illegal class assertion" checkDataHeader :: RdrNameHsType -> P (RdrNameContext, RdrName, [RdrNameHsTyVar]) @@ -158,9 +157,9 @@ checkDataHeader t = returnP ([],c,map UserTyVar ts) checkSimple :: RdrNameHsType -> [RdrName] -> P ((RdrName,[RdrName])) -checkSimple (MonoTyApp l (MonoTyVar a)) xs | isRdrTyVar a +checkSimple (HsAppTy l (HsTyVar a)) xs | isRdrTyVar a = checkSimple l (a:xs) -checkSimple (MonoTyVar t) xs | not (isRdrTyVar t) = returnP (t,xs) +checkSimple (HsTyVar t) xs | not (isRdrTyVar t) = returnP (t,xs) checkSimple t _ = trace (showSDoc (ppr t)) $ parseError "Illegal data/newtype declaration" --------------------------------------------------------------------------- @@ -431,25 +430,25 @@ funTyCon_RDR | otherwise = mkPreludeQual tcName pRELUDE_Name funName tupleCon_RDR arity - | opt_NoImplicitPrelude = mkSrcUnqual dataName (snd (mkTupNameStr arity)) + | opt_NoImplicitPrelude = mkSrcUnqual dataName (snd (mkTupNameStr Boxed arity)) | otherwise = mkPreludeQual dataName pRELUDE_Name - (snd (mkTupNameStr arity)) + (snd (mkTupNameStr Boxed arity)) tupleTyCon_RDR arity - | opt_NoImplicitPrelude = mkSrcUnqual tcName (snd (mkTupNameStr arity)) + | opt_NoImplicitPrelude = mkSrcUnqual tcName (snd (mkTupNameStr Boxed arity)) | otherwise = mkPreludeQual tcName pRELUDE_Name - (snd (mkTupNameStr arity)) + (snd (mkTupNameStr Boxed arity)) ubxTupleCon_RDR arity - | opt_NoImplicitPrelude = mkSrcUnqual dataName (snd (mkUbxTupNameStr arity)) + | opt_NoImplicitPrelude = mkSrcUnqual dataName (snd (mkTupNameStr Unboxed arity)) | otherwise = mkPreludeQual dataName pRELUDE_Name - (snd (mkUbxTupNameStr arity)) + (snd (mkTupNameStr Unboxed arity)) ubxTupleTyCon_RDR arity - | opt_NoImplicitPrelude = mkSrcUnqual tcName (snd (mkUbxTupNameStr arity)) + | opt_NoImplicitPrelude = mkSrcUnqual tcName (snd (mkTupNameStr Unboxed arity)) | otherwise = mkPreludeQual tcName pRELUDE_Name - (snd (mkUbxTupNameStr arity)) + (snd (mkTupNameStr Unboxed arity)) unitName = SLIT("()") funName = SLIT("(->)") diff --git a/ghc/compiler/parser/Parser.y b/ghc/compiler/parser/Parser.y index d5521bfdf0..51bd67a901 100644 --- a/ghc/compiler/parser/Parser.y +++ b/ghc/compiler/parser/Parser.y @@ -1,6 +1,6 @@ {- ----------------------------------------------------------------------------- -$Id: Parser.y,v 1.30 2000/05/23 11:35:37 simonpj Exp $ +$Id: Parser.y,v 1.31 2000/05/25 12:41:17 simonpj Exp $ Haskell grammar. @@ -13,18 +13,19 @@ module Parser ( parse ) where import HsSyn import HsPragmas +import HsTypes ( mkHsTupCon ) import RdrHsSyn import Lex import ParseUtil import RdrName -import PrelMods ( mAIN_Name ) -import OccName ( varName, ipName, dataName, tcClsName, tvName ) +import PrelInfo ( mAIN_Name ) +import OccName ( varName, ipName, tcName, dataName, tcClsName, tvName ) import SrcLoc ( SrcLoc ) import Module import CallConv import CmdLineOpts ( opt_SccProfilingOn ) -import BasicTypes ( Fixity(..), FixityDirection(..), NewOrData(..) ) +import BasicTypes ( Boxity(..), Fixity(..), FixityDirection(..), NewOrData(..) ) import Panic import GlaExts @@ -332,13 +333,13 @@ topdecl :: { RdrBinding } | srcloc 'data' ctype '=' constrs deriving {% checkDataHeader $3 `thenP` \(cs,c,ts) -> returnP (RdrHsDecl (TyClD - (TyData DataType cs c ts (reverse $5) $6 + (TyData DataType cs c ts (reverse $5) (length $5) $6 NoDataPragmas $1))) } | srcloc 'newtype' ctype '=' newconstr deriving {% checkDataHeader $3 `thenP` \(cs,c,ts) -> returnP (RdrHsDecl (TyClD - (TyData NewType cs c ts [$5] $6 + (TyData NewType cs c ts [$5] 1 $6 NoDataPragmas $1))) } | srcloc 'class' ctype fds where @@ -372,7 +373,9 @@ topdecl :: { RdrBinding } { RdrHsDecl (ForD (ForeignDecl $5 FoLabel $7 (mkExtName $4 $5) defaultCallConv $1)) } - | decl { $1 } + | '{-# DEPRECATED' deprecations '#-}' { $2 } + | '{-# RULES' rules '#-}' { $2 } + | decl { $1 } decls :: { [RdrBinding] } : decls ';' decl { $3 : $1 } @@ -390,8 +393,6 @@ decl :: { RdrBinding } (map (\t -> RdrSig (SpecSig $3 t $2)) $5) } | '{-# SPECIALISE' srcloc 'instance' inst_type '#-}' { RdrSig (SpecInstSig $4 $2) } - | '{-# RULES' rules '#-}' { $2 } - | '{-# DEPRECATED' deprecations '#-}' { $2 } opt_phase :: { Maybe Int } : INTEGER { Just (fromInteger $1) } @@ -428,7 +429,7 @@ rules :: { RdrBinding } rule :: { RdrBinding } : STRING rule_forall fexp '=' srcloc exp - { RdrHsDecl (RuleD (RuleDecl $1 [] $2 $3 $6 $5)) } + { RdrHsDecl (RuleD (HsRule $1 [] $2 $3 $6 $5)) } rule_forall :: { [RdrNameRuleBndr] } : 'forall' rule_var_list '.' { $2 } @@ -454,7 +455,8 @@ deprecations :: { RdrBinding } -- SUP: TEMPORARY HACK, not checking for `module Foo' deprecation :: { RdrBinding } : srcloc exportlist STRING - { foldr1 RdrAndBindings [ RdrSig (DeprecSig (Deprecation n $3) $1) | n <- $2 ] } + { foldr RdrAndBindings RdrNullBind + [ RdrHsDecl (DeprecD (Deprecation n $3 $1)) | n <- $2 ] } ----------------------------------------------------------------------------- -- Foreign import/export @@ -508,20 +510,20 @@ ctype :: { RdrNameHsType } | type { $1 } type :: { RdrNameHsType } - : btype '->' type { MonoFunTy $1 $3 } - | ipvar '::' type { MonoIParamTy $1 $3 } + : btype '->' type { HsFunTy $1 $3 } + | ipvar '::' type { mkHsIParamTy $1 $3 } | btype { $1 } btype :: { RdrNameHsType } - : btype atype { MonoTyApp $1 $2 } + : btype atype { HsAppTy $1 $2 } | atype { $1 } atype :: { RdrNameHsType } - : gtycon { MonoTyVar $1 } - | tyvar { MonoTyVar $1 } - | '(' type ',' types ')' { MonoTupleTy ($2 : reverse $4) True } - | '(#' types '#)' { MonoTupleTy (reverse $2) False } - | '[' type ']' { MonoListTy $2 } + : gtycon { HsTyVar $1 } + | tyvar { HsTyVar $1 } + | '(' type ',' types ')' { HsTupleTy (mkHsTupCon tcName Boxed ($2:$4)) ($2 : reverse $4) } + | '(#' types '#)' { HsTupleTy (mkHsTupCon tcName Unboxed $2) (reverse $2) } + | '[' type ']' { HsListTy $2 } | '(' ctype ')' { $2 } gtycon :: { RdrName } @@ -737,8 +739,8 @@ aexp1 :: { RdrNameHsExpr } | gcon { HsVar $1 } | literal { HsLit $1 } | '(' exp ')' { HsPar $2 } - | '(' exp ',' texps ')' { ExplicitTuple ($2 : reverse $4) True } - | '(#' texps '#)' { ExplicitTuple (reverse $2) False } + | '(' exp ',' texps ')' { ExplicitTuple ($2 : reverse $4) Boxed} + | '(#' texps '#)' { ExplicitTuple (reverse $2) Unboxed } | '[' list ']' { $2 } | '(' infixexp qop ')' { SectionL $2 $3 } | '(' qopm infixexp ')' { SectionR $2 $3 } diff --git a/ghc/compiler/parser/RdrHsSyn.lhs b/ghc/compiler/parser/RdrHsSyn.lhs index 4455fdba1e..0d0a01f660 100644 --- a/ghc/compiler/parser/RdrHsSyn.lhs +++ b/ghc/compiler/parser/RdrHsSyn.lhs @@ -38,6 +38,7 @@ module RdrHsSyn ( RdrNameRuleBndr, RdrNameDeprecation, RdrNameHsRecordBinds, + RdrNameFixitySig, RdrBinding(..), RdrMatch(..), @@ -106,13 +107,14 @@ type RdrNameMatch = Match RdrName RdrNamePat type RdrNameMonoBinds = MonoBinds RdrName RdrNamePat type RdrNamePat = InPat RdrName type RdrNameHsType = HsType RdrName -type RdrNameHsTyVar = HsTyVar RdrName +type RdrNameHsTyVar = HsTyVarBndr RdrName type RdrNameSig = Sig RdrName type RdrNameStmt = Stmt RdrName RdrNamePat type RdrNameTyClDecl = TyClDecl RdrName RdrNamePat type RdrNameRuleBndr = RuleBndr RdrName type RdrNameRuleDecl = RuleDecl RdrName RdrNamePat -type RdrNameDeprecation = Deprecation RdrName +type RdrNameDeprecation = DeprecDecl RdrName +type RdrNameFixitySig = FixitySig RdrName type RdrNameHsRecordBinds = HsRecordBinds RdrName RdrNamePat @@ -159,15 +161,14 @@ extract_pred (HsPIParam n ty) acc = extract_ty ty acc extract_tys tys acc = foldr extract_ty acc tys -extract_ty (MonoTyApp ty1 ty2) acc = extract_ty ty1 (extract_ty ty2 acc) -extract_ty (MonoListTy ty) acc = extract_ty ty acc -extract_ty (MonoTupleTy tys _) acc = foldr extract_ty acc tys -extract_ty (MonoFunTy ty1 ty2) acc = extract_ty ty1 (extract_ty ty2 acc) -extract_ty (MonoIParamTy n ty) acc = extract_ty ty acc -extract_ty (MonoDictTy cls tys) acc = foldr extract_ty (cls : acc) tys -extract_ty (MonoUsgTy usg ty) acc = extract_ty ty acc -extract_ty (MonoUsgForAllTy uv ty) acc = extract_ty ty acc -extract_ty (MonoTyVar tv) acc = tv : acc +extract_ty (HsAppTy ty1 ty2) acc = extract_ty ty1 (extract_ty ty2 acc) +extract_ty (HsListTy ty) acc = extract_ty ty acc +extract_ty (HsTupleTy _ tys) acc = foldr extract_ty acc tys +extract_ty (HsFunTy ty1 ty2) acc = extract_ty ty1 (extract_ty ty2 acc) +extract_ty (HsPredTy p) acc = extract_pred p acc +extract_ty (HsUsgTy usg ty) acc = extract_ty ty acc +extract_ty (HsUsgForAllTy uv ty) acc = extract_ty ty acc +extract_ty (HsTyVar tv) acc = tv : acc extract_ty (HsForAllTy Nothing ctxt ty) acc = extract_ctxt ctxt (extract_ty ty acc) extract_ty (HsForAllTy (Just tvs) ctxt ty) acc = acc ++ @@ -293,7 +294,7 @@ cvValSig sig = sig cvInstDeclSig sig = sig cvClassOpSig (Sig var poly_ty src_loc) = ClassOpSig var (panic "cvClassOpSig:dm_name") - (panic "cvClassOpSig:dm_present") + False poly_ty src_loc cvClassOpSig sig = sig \end{code} diff --git a/ghc/compiler/prelude/PrelInfo.lhs b/ghc/compiler/prelude/PrelInfo.lhs index a24196185d..ad67d07d5a 100644 --- a/ghc/compiler/prelude/PrelInfo.lhs +++ b/ghc/compiler/prelude/PrelInfo.lhs @@ -5,7 +5,7 @@ \begin{code} module PrelInfo ( - module ThinAir, + module PrelNames, module MkId, builtinNames, -- Names of things whose *unique* must be known, but @@ -18,51 +18,27 @@ module PrelInfo ( -- deriving(C) clause - -- Random other things - main_NAME, ioTyCon_NAME, - deRefStablePtr_NAME, makeStablePtr_NAME, - bindIO_NAME, returnIO_NAME, + + -- Primop RdrNames + eqH_Char_RDR, ltH_Char_RDR, eqH_Word_RDR, ltH_Word_RDR, + eqH_Addr_RDR, ltH_Addr_RDR, eqH_Float_RDR, ltH_Float_RDR, + eqH_Double_RDR, ltH_Double_RDR, eqH_Int_RDR, ltH_Int_RDR, + geH_RDR, leH_RDR, minusH_RDR, tagToEnumH_RDR, + -- Random other things maybeCharLikeCon, maybeIntLikeCon, needsDataDeclCtxtClassKeys, cCallishClassKeys, cCallishTyKeys, isNoDictClass, isNumericClass, isStandardClass, isCcallishClass, isCreturnableClass, numericTyKeys, fractionalClassKeys, - -- RdrNames for lots of things, mainly used in derivings - eq_RDR, ne_RDR, le_RDR, lt_RDR, ge_RDR, gt_RDR, max_RDR, min_RDR, - compare_RDR, minBound_RDR, maxBound_RDR, enumFrom_RDR, enumFromTo_RDR, - enumFromThen_RDR, enumFromThenTo_RDR, succ_RDR, pred_RDR, fromEnum_RDR, toEnum_RDR, - ratioDataCon_RDR, range_RDR, index_RDR, inRange_RDR, readsPrec_RDR, - readList_RDR, showsPrec_RDR, showList_RDR, plus_RDR, times_RDR, - ltTag_RDR, eqTag_RDR, gtTag_RDR, eqH_Char_RDR, ltH_Char_RDR, - eqH_Word_RDR, ltH_Word_RDR, eqH_Addr_RDR, ltH_Addr_RDR, eqH_Float_RDR, - ltH_Float_RDR, eqH_Double_RDR, ltH_Double_RDR, eqH_Int_RDR, - ltH_Int_RDR, geH_RDR, leH_RDR, minusH_RDR, false_RDR, true_RDR, - and_RDR, not_RDR, append_RDR, map_RDR, compose_RDR, mkInt_RDR, - error_RDR, assertErr_RDR, getTag_RDR, tagToEnumH_RDR, - showString_RDR, showParen_RDR, readParen_RDR, lex_RDR, - showSpace_RDR, showList___RDR, readList___RDR, negate_RDR, - - numClass_RDR, fractionalClass_RDR, eqClass_RDR, - ccallableClass_RDR, creturnableClass_RDR, - monadClass_RDR, enumClass_RDR, ordClass_RDR, - ioDataCon_RDR, - - main_RDR, - - mkTupConRdrName, mkUbxTupConRdrName - ) where #include "HsVersions.h" - - -- friends: -import ThinAir -- Re-export all these import MkId -- Ditto +import PrelNames -- Prelude module names -import PrelMods -- Prelude module names import PrimOp ( PrimOp(..), allThePrimOps, primOpRdrName ) import DataCon ( DataCon, dataConId, dataConWrapId ) import PrimRep ( PrimRep(..) ) @@ -70,18 +46,18 @@ import TysPrim -- TYPES import TysWiredIn -- others: -import RdrName ( RdrName, mkPreludeQual ) +import RdrName ( RdrName ) import Var ( varUnique, Id ) import Name ( Name, OccName, Provenance(..), NameSpace, tcName, clsName, varName, dataName, mkKnownKeyGlobal, getName, mkGlobalName, nameRdrName ) -import RdrName ( rdrNameModule, rdrNameOcc, mkSrcQual ) import Class ( Class, classKey ) -import TyCon ( tyConDataCons, TyCon ) +import TyCon ( tyConDataConsIfAvailable, TyCon ) import Type ( funTyCon ) import Bag +import BasicTypes ( Boxity(..) ) import Unique -- *Key stuff import UniqFM ( UniqFM, listToUFM ) import Util ( isIn ) @@ -110,9 +86,6 @@ builtinNames -- PrimOps , listToBag (map (getName . mkPrimOpId) allThePrimOps) - -- Thin-air ids - , listToBag thinAirIdNames - -- Other names with magic keys , listToBag knownKeyNames ] @@ -123,7 +96,7 @@ builtinNames getTyConNames :: TyCon -> Bag Name getTyConNames tycon = getName tycon `consBag` - unionManyBags (map get_data_con_names (tyConDataCons tycon)) + unionManyBags (map get_data_con_names (tyConDataConsIfAvailable tycon)) -- Synonyms return empty list of constructors where get_data_con_names dc = listToBag [getName (dataConId dc), -- Worker @@ -137,6 +110,35 @@ sense of them in interface pragmas. It's cool, though they all have %************************************************************************ %* * +\subsection{RdrNames for the primops} +%* * +%************************************************************************ + +These can't be in PrelNames, because we get the RdrName from the PrimOp, +which is above PrelNames in the module hierarchy. + +\begin{code} +eqH_Char_RDR = primOpRdrName CharEqOp +ltH_Char_RDR = primOpRdrName CharLtOp +eqH_Word_RDR = primOpRdrName WordEqOp +ltH_Word_RDR = primOpRdrName WordLtOp +eqH_Addr_RDR = primOpRdrName AddrEqOp +ltH_Addr_RDR = primOpRdrName AddrLtOp +eqH_Float_RDR = primOpRdrName FloatEqOp +ltH_Float_RDR = primOpRdrName FloatLtOp +eqH_Double_RDR = primOpRdrName DoubleEqOp +ltH_Double_RDR = primOpRdrName DoubleLtOp +eqH_Int_RDR = primOpRdrName IntEqOp +ltH_Int_RDR = primOpRdrName IntLtOp +geH_RDR = primOpRdrName IntGeOp +leH_RDR = primOpRdrName IntLeOp +minusH_RDR = primOpRdrName IntSubOp + +tagToEnumH_RDR = primOpRdrName TagToEnumOp +\end{code} + +%************************************************************************ +%* * \subsection{Wired in TyCons} %* * %************************************************************************ @@ -172,8 +174,8 @@ prim_tycons , word64PrimTyCon ] -tuple_tycons = unitTyCon : [tupleTyCon i | i <- [2..37] ] -unboxed_tuple_tycons = [unboxedTupleTyCon i | i <- [1..37] ] +tuple_tycons = unitTyCon : [tupleTyCon Boxed i | i <- [2..37] ] +unboxed_tuple_tycons = [tupleTyCon Unboxed i | i <- [1..37] ] data_tycons = [ addrTyCon @@ -198,23 +200,14 @@ data_tycons Ids, Synonyms, Classes and ClassOps with builtin keys. \begin{code} -ioTyCon_NAME = mkKnownKeyGlobal (ioTyCon_RDR, ioTyConKey) -main_NAME = mkKnownKeyGlobal (main_RDR, mainKey) - - -- Operations needed when compiling FFI decls -bindIO_NAME = mkKnownKeyGlobal (bindIO_RDR, bindIOIdKey) -returnIO_NAME = mkKnownKeyGlobal (returnIO_RDR, returnIOIdKey) -deRefStablePtr_NAME = mkKnownKeyGlobal (deRefStablePtr_RDR, deRefStablePtrIdKey) -makeStablePtr_NAME = mkKnownKeyGlobal (makeStablePtr_RDR, makeStablePtrIdKey) - knownKeyNames :: [Name] knownKeyNames - = [main_NAME, ioTyCon_NAME] - ++ - map mkKnownKeyGlobal + = map mkKnownKeyGlobal [ -- Type constructors (synonyms especially) - (orderingTyCon_RDR, orderingTyConKey) + (ioTyCon_RDR, ioTyConKey) + , (main_RDR, mainKey) + , (orderingTyCon_RDR, orderingTyConKey) , (rationalTyCon_RDR, rationalTyConKey) , (ratioDataCon_RDR, ratioDataConKey) , (ratioTyCon_RDR, ratioTyConKey) @@ -268,14 +261,21 @@ knownKeyNames , (makeStablePtr_RDR, makeStablePtrIdKey) , (bindIO_RDR, bindIOIdKey) , (returnIO_RDR, returnIOIdKey) + , (addr2Integer_RDR, addr2IntegerIdKey) + -- Strings and lists , (map_RDR, mapIdKey) , (append_RDR, appendIdKey) + , (unpackCString_RDR, unpackCStringIdKey) + , (unpackCString2_RDR, unpackCString2IdKey) + , (unpackCStringAppend_RDR, unpackCStringAppendIdKey) + , (unpackCStringFoldr_RDR, unpackCStringFoldrIdKey) -- List operations , (concat_RDR, concatIdKey) , (filter_RDR, filterIdKey) , (zip_RDR, zipIdKey) + , (foldr_RDR, foldrIdKey) , (build_RDR, buildIdKey) , (augment_RDR, augmentIdKey) @@ -300,203 +300,12 @@ ToDo: make it do the ``like'' part properly (as in 0.26 and before). \begin{code} maybeCharLikeCon, maybeIntLikeCon :: DataCon -> Bool -maybeCharLikeCon con = getUnique con == charDataConKey -maybeIntLikeCon con = getUnique con == intDataConKey +maybeCharLikeCon con = con `hasKey` charDataConKey +maybeIntLikeCon con = con `hasKey` intDataConKey \end{code} %************************************************************************ %* * -\subsection{Commonly-used RdrNames} -%* * -%************************************************************************ - -These RdrNames are not really "built in", but some parts of the compiler -(notably the deriving mechanism) need to mention their names, and it's convenient -to write them all down in one place. - -\begin{code} -main_RDR = varQual mAIN_Name SLIT("main") -otherwiseId_RDR = varQual pREL_BASE_Name SLIT("otherwise") - -intTyCon_RDR = nameRdrName (getName intTyCon) -ioTyCon_RDR = tcQual pREL_IO_BASE_Name SLIT("IO") -ioDataCon_RDR = dataQual pREL_IO_BASE_Name SLIT("IO") -bindIO_RDR = varQual pREL_IO_BASE_Name SLIT("bindIO") -returnIO_RDR = varQual pREL_IO_BASE_Name SLIT("returnIO") - -orderingTyCon_RDR = tcQual pREL_BASE_Name SLIT("Ordering") - -rationalTyCon_RDR = tcQual pREL_REAL_Name SLIT("Rational") -ratioTyCon_RDR = tcQual pREL_REAL_Name SLIT("Ratio") -ratioDataCon_RDR = dataQual pREL_REAL_Name SLIT(":%") - -byteArrayTyCon_RDR = tcQual pREL_BYTEARR_Name SLIT("ByteArray") -mutableByteArrayTyCon_RDR = tcQual pREL_BYTEARR_Name SLIT("MutableByteArray") - -foreignObjTyCon_RDR = tcQual pREL_IO_BASE_Name SLIT("ForeignObj") -stablePtrTyCon_RDR = tcQual pREL_STABLE_Name SLIT("StablePtr") -stablePtrDataCon_RDR = dataQual pREL_STABLE_Name SLIT("StablePtr") -deRefStablePtr_RDR = varQual pREL_STABLE_Name SLIT("deRefStablePtr") -makeStablePtr_RDR = varQual pREL_STABLE_Name SLIT("makeStablePtr") - --- Random PrelBase data constructors -mkInt_RDR = dataQual pREL_BASE_Name SLIT("I#") -false_RDR = dataQual pREL_BASE_Name SLIT("False") -true_RDR = dataQual pREL_BASE_Name SLIT("True") - --- Random PrelBase functions -and_RDR = varQual pREL_BASE_Name SLIT("&&") -not_RDR = varQual pREL_BASE_Name SLIT("not") -compose_RDR = varQual pREL_BASE_Name SLIT(".") -append_RDR = varQual pREL_BASE_Name SLIT("++") -map_RDR = varQual pREL_BASE_Name SLIT("map") -build_RDR = varQual pREL_BASE_Name SLIT("build") -augment_RDR = varQual pREL_BASE_Name SLIT("augment") - --- Classes Eq and Ord -eqClass_RDR = clsQual pREL_BASE_Name SLIT("Eq") -ordClass_RDR = clsQual pREL_BASE_Name SLIT("Ord") -eq_RDR = varQual pREL_BASE_Name SLIT("==") -ne_RDR = varQual pREL_BASE_Name SLIT("/=") -le_RDR = varQual pREL_BASE_Name SLIT("<=") -lt_RDR = varQual pREL_BASE_Name SLIT("<") -ge_RDR = varQual pREL_BASE_Name SLIT(">=") -gt_RDR = varQual pREL_BASE_Name SLIT(">") -ltTag_RDR = dataQual pREL_BASE_Name SLIT("LT") -eqTag_RDR = dataQual pREL_BASE_Name SLIT("EQ") -gtTag_RDR = dataQual pREL_BASE_Name SLIT("GT") -max_RDR = varQual pREL_BASE_Name SLIT("max") -min_RDR = varQual pREL_BASE_Name SLIT("min") -compare_RDR = varQual pREL_BASE_Name SLIT("compare") - --- Class Monad -monadClass_RDR = clsQual pREL_BASE_Name SLIT("Monad") -monadPlusClass_RDR = clsQual pREL_BASE_Name SLIT("MonadPlus") -thenM_RDR = varQual pREL_BASE_Name SLIT(">>=") -returnM_RDR = varQual pREL_BASE_Name SLIT("return") -failM_RDR = varQual pREL_BASE_Name SLIT("fail") - --- Class Functor -functorClass_RDR = clsQual pREL_BASE_Name SLIT("Functor") - --- Class Show -showClass_RDR = clsQual pREL_SHOW_Name SLIT("Show") -showList___RDR = varQual pREL_SHOW_Name SLIT("showList__") -showsPrec_RDR = varQual pREL_SHOW_Name SLIT("showsPrec") -showList_RDR = varQual pREL_SHOW_Name SLIT("showList") -showSpace_RDR = varQual pREL_SHOW_Name SLIT("showSpace") -showString_RDR = varQual pREL_SHOW_Name SLIT("showString") -showParen_RDR = varQual pREL_SHOW_Name SLIT("showParen") - - --- Class Read -readClass_RDR = clsQual pREL_READ_Name SLIT("Read") -readsPrec_RDR = varQual pREL_READ_Name SLIT("readsPrec") -readList_RDR = varQual pREL_READ_Name SLIT("readList") -readParen_RDR = varQual pREL_READ_Name SLIT("readParen") -lex_RDR = varQual pREL_READ_Name SLIT("lex") -readList___RDR = varQual pREL_READ_Name SLIT("readList__") - - --- Class Num -numClass_RDR = clsQual pREL_NUM_Name SLIT("Num") -fromInt_RDR = varQual pREL_NUM_Name SLIT("fromInt") -fromInteger_RDR = varQual pREL_NUM_Name SLIT("fromInteger") -minus_RDR = varQual pREL_NUM_Name SLIT("-") -negate_RDR = varQual pREL_NUM_Name SLIT("negate") -plus_RDR = varQual pREL_NUM_Name SLIT("+") -times_RDR = varQual pREL_NUM_Name SLIT("*") - --- Other numberic classes -realClass_RDR = clsQual pREL_REAL_Name SLIT("Real") -integralClass_RDR = clsQual pREL_REAL_Name SLIT("Integral") -realFracClass_RDR = clsQual pREL_REAL_Name SLIT("RealFrac") -fractionalClass_RDR = clsQual pREL_REAL_Name SLIT("Fractional") -fromRational_RDR = varQual pREL_REAL_Name SLIT("fromRational") - -floatingClass_RDR = clsQual pREL_FLOAT_Name SLIT("Floating") -realFloatClass_RDR = clsQual pREL_FLOAT_Name SLIT("RealFloat") - --- Class Ix -ixClass_RDR = clsQual pREL_ARR_Name SLIT("Ix") -range_RDR = varQual pREL_ARR_Name SLIT("range") -index_RDR = varQual pREL_ARR_Name SLIT("index") -inRange_RDR = varQual pREL_ARR_Name SLIT("inRange") - --- Class CCallable and CReturnable -ccallableClass_RDR = clsQual pREL_GHC_Name SLIT("CCallable") -creturnableClass_RDR = clsQual pREL_GHC_Name SLIT("CReturnable") - --- Class Enum -enumClass_RDR = clsQual pREL_ENUM_Name SLIT("Enum") -succ_RDR = varQual pREL_ENUM_Name SLIT("succ") -pred_RDR = varQual pREL_ENUM_Name SLIT("pred") -toEnum_RDR = varQual pREL_ENUM_Name SLIT("toEnum") -fromEnum_RDR = varQual pREL_ENUM_Name SLIT("fromEnum") -enumFrom_RDR = varQual pREL_ENUM_Name SLIT("enumFrom") -enumFromTo_RDR = varQual pREL_ENUM_Name SLIT("enumFromTo") -enumFromThen_RDR = varQual pREL_ENUM_Name SLIT("enumFromThen") -enumFromThenTo_RDR = varQual pREL_ENUM_Name SLIT("enumFromThenTo") - --- Class Bounded -boundedClass_RDR = clsQual pREL_ENUM_Name SLIT("Bounded") -minBound_RDR = varQual pREL_ENUM_Name SLIT("minBound") -maxBound_RDR = varQual pREL_ENUM_Name SLIT("maxBound") - - --- List functions -concat_RDR = varQual pREL_LIST_Name SLIT("concat") -filter_RDR = varQual pREL_LIST_Name SLIT("filter") -zip_RDR = varQual pREL_LIST_Name SLIT("zip") - -int8TyCon_RDR = tcQual iNT_Name SLIT("Int8") -int16TyCon_RDR = tcQual iNT_Name SLIT("Int16") -int32TyCon_RDR = tcQual iNT_Name SLIT("Int32") -int64TyCon_RDR = tcQual pREL_ADDR_Name SLIT("Int64") - -word8TyCon_RDR = tcQual wORD_Name SLIT("Word8") -word16TyCon_RDR = tcQual wORD_Name SLIT("Word16") -word32TyCon_RDR = tcQual wORD_Name SLIT("Word32") -word64TyCon_RDR = tcQual pREL_ADDR_Name SLIT("Word64") - -error_RDR = varQual pREL_ERR_Name SLIT("error") -assert_RDR = varQual pREL_GHC_Name SLIT("assert") -assertErr_RDR = varQual pREL_ERR_Name SLIT("assertError") -runSTRep_RDR = varQual pREL_ST_Name SLIT("runSTRep") - -eqH_Char_RDR = primOpRdrName CharEqOp -ltH_Char_RDR = primOpRdrName CharLtOp -eqH_Word_RDR = primOpRdrName WordEqOp -ltH_Word_RDR = primOpRdrName WordLtOp -eqH_Addr_RDR = primOpRdrName AddrEqOp -ltH_Addr_RDR = primOpRdrName AddrLtOp -eqH_Float_RDR = primOpRdrName FloatEqOp -ltH_Float_RDR = primOpRdrName FloatLtOp -eqH_Double_RDR = primOpRdrName DoubleEqOp -ltH_Double_RDR = primOpRdrName DoubleLtOp -eqH_Int_RDR = primOpRdrName IntEqOp -ltH_Int_RDR = primOpRdrName IntLtOp -geH_RDR = primOpRdrName IntGeOp -leH_RDR = primOpRdrName IntLeOp -minusH_RDR = primOpRdrName IntSubOp - -tagToEnumH_RDR = primOpRdrName TagToEnumOp -getTag_RDR = varQual pREL_GHC_Name SLIT("getTag#") -\end{code} - -\begin{code} -mkTupConRdrName :: Int -> RdrName -mkTupConRdrName arity = case mkTupNameStr arity of - (mod, occ) -> dataQual mod occ - -mkUbxTupConRdrName :: Int -> RdrName -mkUbxTupConRdrName arity = case mkUbxTupNameStr arity of - (mod, occ) -> dataQual mod occ -\end{code} - - -%************************************************************************ -%* * \subsection[Class-std-groups]{Standard groups of Prelude classes} %* * %************************************************************************ @@ -633,17 +442,3 @@ noDictClassKeys -- These classes are used only for type annotations; = cCallishClassKeys \end{code} - -%************************************************************************ -%* * -\subsection{Local helpers} -%* * -%************************************************************************ - -\begin{code} -varQual = mkPreludeQual varName -dataQual = mkPreludeQual dataName -tcQual = mkPreludeQual tcName -clsQual = mkPreludeQual clsName -\end{code} - diff --git a/ghc/compiler/prelude/PrelMods.lhs b/ghc/compiler/prelude/PrelMods.lhs deleted file mode 100644 index 885685d7c4..0000000000 --- a/ghc/compiler/prelude/PrelMods.lhs +++ /dev/null @@ -1,101 +0,0 @@ -% -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 -% -\section[PrelMods]{Definitions of prelude modules} - -The strings identify built-in prelude modules. They are -defined here so as to avod - -[oh dear, looks like the recursive module monster caught up with - and gobbled whoever was writing the above :-) -- SOF ] - -\begin{code} -module PrelMods - ( - mkTupNameStr, mkUbxTupNameStr, - - pREL_GHC, pREL_BASE, pREL_ADDR, pREL_STABLE, - pREL_IO_BASE, pREL_PACK, pREL_ERR, pREL_NUM, pREL_FLOAT, pREL_REAL, - - pREL_GHC_Name, pRELUDE_Name, - mAIN_Name, pREL_MAIN_Name, pREL_ERR_Name, - pREL_BASE_Name, pREL_NUM_Name, pREL_LIST_Name, - pREL_TUP_Name, pREL_ADDR_Name, pREL_READ_Name, - pREL_PACK_Name, pREL_CONC_Name, pREL_IO_BASE_Name, - pREL_ST_Name, pREL_ARR_Name, pREL_BYTEARR_Name, pREL_FOREIGN_Name, - pREL_STABLE_Name, pREL_SHOW_Name, pREL_ENUM_Name, iNT_Name, wORD_Name, - pREL_REAL_Name, pREL_FLOAT_Name - ) where - -#include "HsVersions.h" - -import Module ( Module, ModuleName, mkPrelModule, mkSrcModule ) -import Util ( nOfThem ) -import Panic ( panic ) -\end{code} - -\begin{code} -pRELUDE_Name = mkSrcModule "Prelude" -pREL_GHC_Name = mkSrcModule "PrelGHC" -- Primitive types and values -pREL_BASE_Name = mkSrcModule "PrelBase" -pREL_ENUM_Name = mkSrcModule "PrelEnum" -pREL_SHOW_Name = mkSrcModule "PrelShow" -pREL_READ_Name = mkSrcModule "PrelRead" -pREL_NUM_Name = mkSrcModule "PrelNum" -pREL_LIST_Name = mkSrcModule "PrelList" -pREL_TUP_Name = mkSrcModule "PrelTup" -pREL_PACK_Name = mkSrcModule "PrelPack" -pREL_CONC_Name = mkSrcModule "PrelConc" -pREL_IO_BASE_Name = mkSrcModule "PrelIOBase" -pREL_ST_Name = mkSrcModule "PrelST" -pREL_ARR_Name = mkSrcModule "PrelArr" -pREL_BYTEARR_Name = mkSrcModule "PrelByteArr" -pREL_FOREIGN_Name = mkSrcModule "PrelForeign" -pREL_STABLE_Name = mkSrcModule "PrelStable" -pREL_ADDR_Name = mkSrcModule "PrelAddr" -pREL_ERR_Name = mkSrcModule "PrelErr" -pREL_REAL_Name = mkSrcModule "PrelReal" -pREL_FLOAT_Name = mkSrcModule "PrelFloat" - -pREL_MAIN_Name = mkSrcModule "PrelMain" -mAIN_Name = mkSrcModule "Main" -iNT_Name = mkSrcModule "Int" -wORD_Name = mkSrcModule "Word" - -pREL_GHC = mkPrelModule pREL_GHC_Name -pREL_BASE = mkPrelModule pREL_BASE_Name -pREL_ADDR = mkPrelModule pREL_ADDR_Name -pREL_STABLE = mkPrelModule pREL_STABLE_Name -pREL_IO_BASE = mkPrelModule pREL_IO_BASE_Name -pREL_PACK = mkPrelModule pREL_PACK_Name -pREL_ERR = mkPrelModule pREL_ERR_Name -pREL_NUM = mkPrelModule pREL_NUM_Name -pREL_REAL = mkPrelModule pREL_REAL_Name -pREL_FLOAT = mkPrelModule pREL_FLOAT_Name -\end{code} - -%************************************************************************ -%* * -\subsection{Constructing the names of tuples -%* * -%************************************************************************ - -\begin{code} -mkTupNameStr, mkUbxTupNameStr :: Int -> (ModuleName, FAST_STRING) - -mkTupNameStr 0 = (pREL_BASE_Name, SLIT("()")) -mkTupNameStr 1 = panic "Name.mkTupNameStr: 1 ???" -mkTupNameStr 2 = (pREL_TUP_Name, _PK_ "(,)") -- not strictly necessary -mkTupNameStr 3 = (pREL_TUP_Name, _PK_ "(,,)") -- ditto -mkTupNameStr 4 = (pREL_TUP_Name, _PK_ "(,,,)") -- ditto -mkTupNameStr n = (pREL_TUP_Name, _PK_ ("(" ++ nOfThem (n-1) ',' ++ ")")) - -mkUbxTupNameStr 0 = panic "Name.mkUbxTupNameStr: 0 ???" -mkUbxTupNameStr 1 = (pREL_GHC_Name, _PK_ "(# #)") -- 1 and 0 both make sense!!! -mkUbxTupNameStr 2 = (pREL_GHC_Name, _PK_ "(#,#)") -mkUbxTupNameStr 3 = (pREL_GHC_Name, _PK_ "(#,,#)") -mkUbxTupNameStr 4 = (pREL_GHC_Name, _PK_ "(#,,,#)") -mkUbxTupNameStr n = (pREL_GHC_Name, _PK_ ("(#" ++ nOfThem (n-1) ',' ++ "#)")) -\end{code} - - diff --git a/ghc/compiler/prelude/PrelNames.lhs b/ghc/compiler/prelude/PrelNames.lhs new file mode 100644 index 0000000000..0d4328d278 --- /dev/null +++ b/ghc/compiler/prelude/PrelNames.lhs @@ -0,0 +1,341 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 +% +\section[PrelNames]{Definitions of prelude modules} + +The strings identify built-in prelude modules. They are +defined here so as to avod + +[oh dear, looks like the recursive module monster caught up with + and gobbled whoever was writing the above :-) -- SOF ] + +\begin{code} +module PrelNames + ( + -- Prelude modules + pREL_GHC, pREL_BASE, pREL_ADDR, pREL_STABLE, + pREL_IO_BASE, pREL_PACK, pREL_ERR, pREL_NUM, pREL_FLOAT, pREL_REAL, + + -- Module names (both Prelude and otherwise) + pREL_GHC_Name, pRELUDE_Name, + mAIN_Name, pREL_MAIN_Name, pREL_ERR_Name, + pREL_BASE_Name, pREL_NUM_Name, pREL_LIST_Name, + pREL_TUP_Name, pREL_ADDR_Name, pREL_READ_Name, + pREL_PACK_Name, pREL_CONC_Name, pREL_IO_BASE_Name, + pREL_ST_Name, pREL_ARR_Name, pREL_BYTEARR_Name, pREL_FOREIGN_Name, + pREL_STABLE_Name, pREL_SHOW_Name, pREL_ENUM_Name, iNT_Name, wORD_Name, + pREL_REAL_Name, pREL_FLOAT_Name, + + -- RdrNames for lots of things, mainly used in derivings + eq_RDR, ne_RDR, le_RDR, lt_RDR, ge_RDR, gt_RDR, max_RDR, min_RDR, + compare_RDR, minBound_RDR, maxBound_RDR, enumFrom_RDR, enumFromTo_RDR, + enumFromThen_RDR, enumFromThenTo_RDR, succ_RDR, pred_RDR, fromEnum_RDR, toEnum_RDR, + ratioDataCon_RDR, range_RDR, index_RDR, inRange_RDR, readsPrec_RDR, + readList_RDR, showsPrec_RDR, showList_RDR, plus_RDR, times_RDR, + ltTag_RDR, eqTag_RDR, gtTag_RDR, false_RDR, true_RDR, + and_RDR, not_RDR, append_RDR, map_RDR, compose_RDR, mkInt_RDR, + error_RDR, assertErr_RDR, + showString_RDR, showParen_RDR, readParen_RDR, lex_RDR, + showSpace_RDR, showList___RDR, readList___RDR, negate_RDR, + addr2Integer_RDR, ioTyCon_RDR, + foldr_RDR, build_RDR, getTag_RDR, + + orderingTyCon_RDR, rationalTyCon_RDR, ratioTyCon_RDR, byteArrayTyCon_RDR, + mutableByteArrayTyCon_RDR, foreignObjTyCon_RDR, + intTyCon_RDR, stablePtrTyCon_RDR, stablePtrDataCon_RDR, + int8TyCon_RDR, int16TyCon_RDR, int32TyCon_RDR, int64TyCon_RDR, + word8TyCon_RDR, word16TyCon_RDR, word32TyCon_RDR, word64TyCon_RDR, + + boundedClass_RDR, monadPlusClass_RDR, functorClass_RDR, showClass_RDR, + realClass_RDR, integralClass_RDR, floatingClass_RDR, realFracClass_RDR, + realFloatClass_RDR, readClass_RDR, ixClass_RDR, + fromInt_RDR, fromInteger_RDR, minus_RDR, fromRational_RDR, + + bindIO_RDR, returnIO_RDR, thenM_RDR, returnM_RDR, failM_RDR, + + deRefStablePtr_RDR, makeStablePtr_RDR, + concat_RDR, filter_RDR, zip_RDR, augment_RDR, + otherwiseId_RDR, assert_RDR, runSTRep_RDR, + + unpackCString_RDR, unpackCString2_RDR, unpackCStringAppend_RDR, unpackCStringFoldr_RDR, + numClass_RDR, fractionalClass_RDR, eqClass_RDR, + ccallableClass_RDR, creturnableClass_RDR, + monadClass_RDR, enumClass_RDR, ordClass_RDR, + ioDataCon_RDR, + + main_RDR, + + mkTupNameStr, mkTupConRdrName + + ) where + +#include "HsVersions.h" + +import Module ( Module, ModuleName, mkPrelModule, mkSrcModule ) +import OccName ( NameSpace, varName, dataName, tcName, clsName ) +import RdrName ( RdrName, mkPreludeQual ) +import BasicTypes ( Boxity(..), Arity ) +import Util ( nOfThem ) +import Panic ( panic ) +\end{code} + +%************************************************************************ +%* * +\subsection{Module names} +%* * +%************************************************************************ + +\begin{code} +pRELUDE_Name = mkSrcModule "Prelude" +pREL_GHC_Name = mkSrcModule "PrelGHC" -- Primitive types and values +pREL_BASE_Name = mkSrcModule "PrelBase" +pREL_ENUM_Name = mkSrcModule "PrelEnum" +pREL_SHOW_Name = mkSrcModule "PrelShow" +pREL_READ_Name = mkSrcModule "PrelRead" +pREL_NUM_Name = mkSrcModule "PrelNum" +pREL_LIST_Name = mkSrcModule "PrelList" +pREL_TUP_Name = mkSrcModule "PrelTup" +pREL_PACK_Name = mkSrcModule "PrelPack" +pREL_CONC_Name = mkSrcModule "PrelConc" +pREL_IO_BASE_Name = mkSrcModule "PrelIOBase" +pREL_ST_Name = mkSrcModule "PrelST" +pREL_ARR_Name = mkSrcModule "PrelArr" +pREL_BYTEARR_Name = mkSrcModule "PrelByteArr" +pREL_FOREIGN_Name = mkSrcModule "PrelForeign" +pREL_STABLE_Name = mkSrcModule "PrelStable" +pREL_ADDR_Name = mkSrcModule "PrelAddr" +pREL_ERR_Name = mkSrcModule "PrelErr" +pREL_REAL_Name = mkSrcModule "PrelReal" +pREL_FLOAT_Name = mkSrcModule "PrelFloat" + +pREL_MAIN_Name = mkSrcModule "PrelMain" +mAIN_Name = mkSrcModule "Main" +iNT_Name = mkSrcModule "Int" +wORD_Name = mkSrcModule "Word" + +pREL_GHC = mkPrelModule pREL_GHC_Name +pREL_BASE = mkPrelModule pREL_BASE_Name +pREL_ADDR = mkPrelModule pREL_ADDR_Name +pREL_STABLE = mkPrelModule pREL_STABLE_Name +pREL_IO_BASE = mkPrelModule pREL_IO_BASE_Name +pREL_PACK = mkPrelModule pREL_PACK_Name +pREL_ERR = mkPrelModule pREL_ERR_Name +pREL_NUM = mkPrelModule pREL_NUM_Name +pREL_REAL = mkPrelModule pREL_REAL_Name +pREL_FLOAT = mkPrelModule pREL_FLOAT_Name +\end{code} + +%************************************************************************ +%* * +\subsection{Constructing the names of tuples +%* * +%************************************************************************ + +\begin{code} +mkTupNameStr :: Boxity -> Int -> (ModuleName, FAST_STRING) + +mkTupNameStr Boxed 0 = (pREL_BASE_Name, SLIT("()")) +mkTupNameStr Boxed 1 = panic "Name.mkTupNameStr: 1 ???" +mkTupNameStr Boxed 2 = (pREL_TUP_Name, _PK_ "(,)") -- not strictly necessary +mkTupNameStr Boxed 3 = (pREL_TUP_Name, _PK_ "(,,)") -- ditto +mkTupNameStr Boxed 4 = (pREL_TUP_Name, _PK_ "(,,,)") -- ditto +mkTupNameStr Boxed n = (pREL_TUP_Name, _PK_ ("(" ++ nOfThem (n-1) ',' ++ ")")) + +mkTupNameStr Unboxed 0 = panic "Name.mkUbxTupNameStr: 0 ???" +mkTupNameStr Unboxed 1 = (pREL_GHC_Name, _PK_ "(# #)") -- 1 and 0 both make sense!!! +mkTupNameStr Unboxed 2 = (pREL_GHC_Name, _PK_ "(#,#)") +mkTupNameStr Unboxed 3 = (pREL_GHC_Name, _PK_ "(#,,#)") +mkTupNameStr Unboxed 4 = (pREL_GHC_Name, _PK_ "(#,,,#)") +mkTupNameStr Unboxed n = (pREL_GHC_Name, _PK_ ("(#" ++ nOfThem (n-1) ',' ++ "#)")) + +mkTupConRdrName :: NameSpace -> Boxity -> Arity -> RdrName +mkTupConRdrName space boxity arity = case mkTupNameStr boxity arity of + (mod, occ) -> mkPreludeQual space mod occ +\end{code} + + + +%************************************************************************ +%* * +\subsection{Commonly-used RdrNames} +%* * +%************************************************************************ + +These RdrNames are not really "built in", but some parts of the compiler +(notably the deriving mechanism) need to mention their names, and it's convenient +to write them all down in one place. + +\begin{code} +main_RDR = varQual mAIN_Name SLIT("main") + +ioTyCon_RDR = tcQual pREL_IO_BASE_Name SLIT("IO") +ioDataCon_RDR = dataQual pREL_IO_BASE_Name SLIT("IO") +bindIO_RDR = varQual pREL_IO_BASE_Name SLIT("bindIO") +returnIO_RDR = varQual pREL_IO_BASE_Name SLIT("returnIO") + + +rationalTyCon_RDR = tcQual pREL_REAL_Name SLIT("Rational") +ratioTyCon_RDR = tcQual pREL_REAL_Name SLIT("Ratio") +ratioDataCon_RDR = dataQual pREL_REAL_Name SLIT(":%") + +byteArrayTyCon_RDR = tcQual pREL_BYTEARR_Name SLIT("ByteArray") +mutableByteArrayTyCon_RDR = tcQual pREL_BYTEARR_Name SLIT("MutableByteArray") + +foreignObjTyCon_RDR = tcQual pREL_IO_BASE_Name SLIT("ForeignObj") +stablePtrTyCon_RDR = tcQual pREL_STABLE_Name SLIT("StablePtr") +stablePtrDataCon_RDR = dataQual pREL_STABLE_Name SLIT("StablePtr") +deRefStablePtr_RDR = varQual pREL_STABLE_Name SLIT("deRefStablePtr") +makeStablePtr_RDR = varQual pREL_STABLE_Name SLIT("makeStablePtr") + +-- Random PrelBase data types and constructors +intTyCon_RDR = tcQual pREL_BASE_Name SLIT("Int") +orderingTyCon_RDR = tcQual pREL_BASE_Name SLIT("Ordering") +mkInt_RDR = dataQual pREL_BASE_Name SLIT("I#") +false_RDR = dataQual pREL_BASE_Name SLIT("False") +true_RDR = dataQual pREL_BASE_Name SLIT("True") + +-- Random PrelBase functions +otherwiseId_RDR = varQual pREL_BASE_Name SLIT("otherwise") +and_RDR = varQual pREL_BASE_Name SLIT("&&") +not_RDR = varQual pREL_BASE_Name SLIT("not") +compose_RDR = varQual pREL_BASE_Name SLIT(".") +append_RDR = varQual pREL_BASE_Name SLIT("++") +foldr_RDR = varQual pREL_BASE_Name SLIT("foldr") +map_RDR = varQual pREL_BASE_Name SLIT("map") +build_RDR = varQual pREL_BASE_Name SLIT("build") +augment_RDR = varQual pREL_BASE_Name SLIT("augment") + +-- Strings +unpackCString_RDR = varQual pREL_BASE_Name SLIT("unpackCString#") +unpackCString2_RDR = varQual pREL_BASE_Name SLIT("unpackNBytes#") +unpackCStringAppend_RDR = varQual pREL_BASE_Name SLIT("unpackAppendCString#") +unpackCStringFoldr_RDR = varQual pREL_BASE_Name SLIT("unpackFoldrCString#") + +-- Classes Eq and Ord +eqClass_RDR = clsQual pREL_BASE_Name SLIT("Eq") +ordClass_RDR = clsQual pREL_BASE_Name SLIT("Ord") +eq_RDR = varQual pREL_BASE_Name SLIT("==") +ne_RDR = varQual pREL_BASE_Name SLIT("/=") +le_RDR = varQual pREL_BASE_Name SLIT("<=") +lt_RDR = varQual pREL_BASE_Name SLIT("<") +ge_RDR = varQual pREL_BASE_Name SLIT(">=") +gt_RDR = varQual pREL_BASE_Name SLIT(">") +ltTag_RDR = dataQual pREL_BASE_Name SLIT("LT") +eqTag_RDR = dataQual pREL_BASE_Name SLIT("EQ") +gtTag_RDR = dataQual pREL_BASE_Name SLIT("GT") +max_RDR = varQual pREL_BASE_Name SLIT("max") +min_RDR = varQual pREL_BASE_Name SLIT("min") +compare_RDR = varQual pREL_BASE_Name SLIT("compare") + +-- Class Monad +monadClass_RDR = clsQual pREL_BASE_Name SLIT("Monad") +monadPlusClass_RDR = clsQual pREL_BASE_Name SLIT("MonadPlus") +thenM_RDR = varQual pREL_BASE_Name SLIT(">>=") +returnM_RDR = varQual pREL_BASE_Name SLIT("return") +failM_RDR = varQual pREL_BASE_Name SLIT("fail") + +-- Class Functor +functorClass_RDR = clsQual pREL_BASE_Name SLIT("Functor") + +-- Class Show +showClass_RDR = clsQual pREL_SHOW_Name SLIT("Show") +showList___RDR = varQual pREL_SHOW_Name SLIT("showList__") +showsPrec_RDR = varQual pREL_SHOW_Name SLIT("showsPrec") +showList_RDR = varQual pREL_SHOW_Name SLIT("showList") +showSpace_RDR = varQual pREL_SHOW_Name SLIT("showSpace") +showString_RDR = varQual pREL_SHOW_Name SLIT("showString") +showParen_RDR = varQual pREL_SHOW_Name SLIT("showParen") + + +-- Class Read +readClass_RDR = clsQual pREL_READ_Name SLIT("Read") +readsPrec_RDR = varQual pREL_READ_Name SLIT("readsPrec") +readList_RDR = varQual pREL_READ_Name SLIT("readList") +readParen_RDR = varQual pREL_READ_Name SLIT("readParen") +lex_RDR = varQual pREL_READ_Name SLIT("lex") +readList___RDR = varQual pREL_READ_Name SLIT("readList__") + + +-- Class Num +numClass_RDR = clsQual pREL_NUM_Name SLIT("Num") +fromInt_RDR = varQual pREL_NUM_Name SLIT("fromInt") +fromInteger_RDR = varQual pREL_NUM_Name SLIT("fromInteger") +minus_RDR = varQual pREL_NUM_Name SLIT("-") +negate_RDR = varQual pREL_NUM_Name SLIT("negate") +plus_RDR = varQual pREL_NUM_Name SLIT("+") +times_RDR = varQual pREL_NUM_Name SLIT("*") +addr2Integer_RDR = varQual pREL_NUM_Name SLIT("addr2Integer") + +-- Other numberic classes +realClass_RDR = clsQual pREL_REAL_Name SLIT("Real") +integralClass_RDR = clsQual pREL_REAL_Name SLIT("Integral") +realFracClass_RDR = clsQual pREL_REAL_Name SLIT("RealFrac") +fractionalClass_RDR = clsQual pREL_REAL_Name SLIT("Fractional") +fromRational_RDR = varQual pREL_REAL_Name SLIT("fromRational") + +floatingClass_RDR = clsQual pREL_FLOAT_Name SLIT("Floating") +realFloatClass_RDR = clsQual pREL_FLOAT_Name SLIT("RealFloat") + +-- Class Ix +ixClass_RDR = clsQual pREL_ARR_Name SLIT("Ix") +range_RDR = varQual pREL_ARR_Name SLIT("range") +index_RDR = varQual pREL_ARR_Name SLIT("index") +inRange_RDR = varQual pREL_ARR_Name SLIT("inRange") + +-- Class CCallable and CReturnable +ccallableClass_RDR = clsQual pREL_GHC_Name SLIT("CCallable") +creturnableClass_RDR = clsQual pREL_GHC_Name SLIT("CReturnable") + +-- Class Enum +enumClass_RDR = clsQual pREL_ENUM_Name SLIT("Enum") +succ_RDR = varQual pREL_ENUM_Name SLIT("succ") +pred_RDR = varQual pREL_ENUM_Name SLIT("pred") +toEnum_RDR = varQual pREL_ENUM_Name SLIT("toEnum") +fromEnum_RDR = varQual pREL_ENUM_Name SLIT("fromEnum") +enumFrom_RDR = varQual pREL_ENUM_Name SLIT("enumFrom") +enumFromTo_RDR = varQual pREL_ENUM_Name SLIT("enumFromTo") +enumFromThen_RDR = varQual pREL_ENUM_Name SLIT("enumFromThen") +enumFromThenTo_RDR = varQual pREL_ENUM_Name SLIT("enumFromThenTo") + +-- Class Bounded +boundedClass_RDR = clsQual pREL_ENUM_Name SLIT("Bounded") +minBound_RDR = varQual pREL_ENUM_Name SLIT("minBound") +maxBound_RDR = varQual pREL_ENUM_Name SLIT("maxBound") + + +-- List functions +concat_RDR = varQual pREL_LIST_Name SLIT("concat") +filter_RDR = varQual pREL_LIST_Name SLIT("filter") +zip_RDR = varQual pREL_LIST_Name SLIT("zip") + +int8TyCon_RDR = tcQual iNT_Name SLIT("Int8") +int16TyCon_RDR = tcQual iNT_Name SLIT("Int16") +int32TyCon_RDR = tcQual iNT_Name SLIT("Int32") +int64TyCon_RDR = tcQual pREL_ADDR_Name SLIT("Int64") + +word8TyCon_RDR = tcQual wORD_Name SLIT("Word8") +word16TyCon_RDR = tcQual wORD_Name SLIT("Word16") +word32TyCon_RDR = tcQual wORD_Name SLIT("Word32") +word64TyCon_RDR = tcQual pREL_ADDR_Name SLIT("Word64") + +error_RDR = varQual pREL_ERR_Name SLIT("error") +assert_RDR = varQual pREL_GHC_Name SLIT("assert") +getTag_RDR = varQual pREL_GHC_Name SLIT("getTag#") +assertErr_RDR = varQual pREL_ERR_Name SLIT("assertError") +runSTRep_RDR = varQual pREL_ST_Name SLIT("runSTRep") +\end{code} + + +%************************************************************************ +%* * +\subsection{Local helpers} +%* * +%************************************************************************ + +\begin{code} +varQual = mkPreludeQual varName +dataQual = mkPreludeQual dataName +tcQual = mkPreludeQual tcName +clsQual = mkPreludeQual clsName +\end{code} + diff --git a/ghc/compiler/prelude/PrelRules.lhs b/ghc/compiler/prelude/PrelRules.lhs index 63e986330c..5f2c0df729 100644 --- a/ghc/compiler/prelude/PrelRules.lhs +++ b/ghc/compiler/prelude/PrelRules.lhs @@ -21,15 +21,17 @@ import Literal ( Literal(..), isLitLitLit, mkMachInt, mkMachWord , float2IntLit, int2FloatLit, double2IntLit, int2DoubleLit , addr2IntLit, int2AddrLit, float2DoubleLit, double2FloatLit ) +import RdrName ( RdrName ) import PrimOp ( PrimOp(..), primOpOcc ) import TysWiredIn ( trueDataConId, falseDataConId ) -import TyCon ( tyConDataCons, isEnumerationTyCon, isNewTyCon ) +import TyCon ( tyConDataConsIfAvailable, isEnumerationTyCon, isNewTyCon ) import DataCon ( DataCon, dataConTag, dataConRepArity, dataConTyCon, dataConId, fIRST_TAG ) import CoreUnfold ( maybeUnfoldingTemplate ) import CoreUtils ( exprIsValue, cheapEqExpr, exprIsConApp_maybe ) import Type ( splitTyConApp_maybe ) import OccName ( occNameUserString) -import ThinAir ( unpackCStringFoldrId ) +import PrelNames ( unpackCStringFoldr_RDR ) +import Unique ( unpackCStringFoldrIdKey, hasKey ) import Maybes ( maybeToBool ) import Char ( ord, chr ) import Bits ( Bits(..) ) @@ -55,7 +57,7 @@ primOpRule op = BuiltinRule (primop_rule op) where op_name = _PK_ (occNameUserString (primOpOcc op)) - op_name_case = op_name _APPEND_ SLIT("case") + op_name_case = op_name _APPEND_ SLIT("->case") -- ToDo: something for integer-shift ops? -- NotOp @@ -404,11 +406,15 @@ seqRule other = Nothing \begin{code} tagToEnumRule [Type ty, Lit (MachInt i)] = ASSERT( isEnumerationTyCon tycon ) - Just (SLIT("TagToEnum"), Var (dataConId dc)) + case filter correct_tag (tyConDataConsIfAvailable tycon) of + + + [] -> Nothing -- Abstract type + (dc:rest) -> ASSERT( null rest ) + Just (SLIT("TagToEnum"), Var (dataConId dc)) where + correct_tag dc = (dataConTag dc - fIRST_TAG) == tag tag = fromInteger i - constrs = tyConDataCons tycon - (dc:_) = [ dc | dc <- constrs, tag == dataConTag dc - fIRST_TAG ] (Just (tycon,_)) = splitTyConApp_maybe ty tagToEnumRule other = Nothing @@ -438,15 +444,14 @@ dataToTagRule other = Nothing %************************************************************************ \begin{code} -builtinRules :: [ProtoCoreRule] +builtinRules :: [(RdrName, CoreRule)] -- Rules for non-primops that can't be expressed using a RULE pragma builtinRules - = [ ProtoCoreRule False unpackCStringFoldrId - (BuiltinRule match_append_lit_str) + = [ (unpackCStringFoldr_RDR, BuiltinRule match_append_lit_str) ] --- unpack "foo" c (unpack "baz" c n) = unpack "foobaz" c n +-- unpackFoldrCString# "foo" c (unpackFoldrCString# "baz" c n) = unpackFoldrCString# "foobaz" c n match_append_lit_str [Type ty1, Lit (MachStr s1), @@ -456,7 +461,7 @@ match_append_lit_str [Type ty1, `App` c2 `App` n ] - | unpk == unpackCStringFoldrId && + | unpk `hasKey` unpackCStringFoldrIdKey && c1 `cheapEqExpr` c2 = ASSERT( ty1 == ty2 ) Just (SLIT("AppendLitString"), diff --git a/ghc/compiler/prelude/PrimOp.lhs b/ghc/compiler/prelude/PrimOp.lhs index 7a0627d6f0..a55af165de 100644 --- a/ghc/compiler/prelude/PrimOp.lhs +++ b/ghc/compiler/prelude/PrimOp.lhs @@ -42,9 +42,9 @@ import Type ( Type, mkForAllTys, mkForAllTy, mkFunTy, mkFunTys, mkTyVarTys, UsageAnn(..), mkUsgTy ) import Unique ( Unique, mkPrimOpIdUnique ) -import BasicTypes ( Arity ) +import BasicTypes ( Arity, Boxity(..) ) import CStrings ( CLabelString, pprCLabelString ) -import PrelMods ( pREL_GHC, pREL_GHC_Name ) +import PrelNames ( pREL_GHC, pREL_GHC_Name ) import Outputable import Util ( assoc, zipWithEqual ) import GlaExts ( Int(..), Int#, (==#) ) @@ -832,9 +832,10 @@ an_Integer_and_Int_tys = [intPrimTy, byteArrayPrimTy, -- Integer intPrimTy] -unboxedPair = mkUnboxedTupleTy 2 -unboxedTriple = mkUnboxedTupleTy 3 -unboxedQuadruple = mkUnboxedTupleTy 4 +unboxedSingleton = mkTupleTy Unboxed 1 +unboxedPair = mkTupleTy Unboxed 2 +unboxedTriple = mkTupleTy Unboxed 3 +unboxedQuadruple = mkTupleTy Unboxed 4 mkIOTy ty = mkFunTy realWorldStatePrimTy (unboxedPair [realWorldStatePrimTy,ty]) @@ -1270,7 +1271,7 @@ primOpInfo WriteArrayOp primOpInfo IndexArrayOp = let { elt = alphaTy; elt_tv = alphaTyVar } in mkGenPrimOp SLIT("indexArray#") [elt_tv] [mkArrayPrimTy elt, intPrimTy] - (mkUnboxedTupleTy 1 [elt]) + (unboxedSingleton [elt]) --------------------------------------------------------------------------- -- Primitive arrays full of unboxed bytes: @@ -2302,8 +2303,8 @@ primOpUsg op Nothing -> pprPanic "primOpUsg:inFun" (ppr op <+> ppr ty) inUB fs ty = case splitTyConApp_maybe ty of - Just (tc,tys) -> ASSERT( tc == unboxedTupleTyCon (length fs) ) - mkUnboxedTupleTy (length fs) (zipWithEqual "primOpUsg" + Just (tc,tys) -> ASSERT( tc == tupleTyCon Unboxed (length fs) ) + mkTupleTy Unboxed (length fs) (zipWithEqual "primOpUsg" ($) fs tys) Nothing -> pprPanic "primOpUsg:inUB" (ppr op <+> ppr ty) \end{code} @@ -2409,6 +2410,7 @@ data CCall Bool -- True <=> really a "casm" Bool -- True <=> might invoke Haskell GC CallConv -- calling convention to use. + deriving( Eq ) data CCallTarget = StaticTarget CLabelString -- An "unboxed" ccall# to `fn'. @@ -2416,6 +2418,7 @@ data CCallTarget -- (unique is used to generate a 'typedef' to cast -- the function pointer if compiling the ccall# down to -- .hc code - can't do this inline for tedious reasons.) + deriving( Eq ) ccallMayGC :: CCall -> Bool ccallMayGC (CCall _ _ may_gc _) = may_gc diff --git a/ghc/compiler/prelude/ThinAir.lhs b/ghc/compiler/prelude/ThinAir.lhs deleted file mode 100644 index 8852598b64..0000000000 --- a/ghc/compiler/prelude/ThinAir.lhs +++ /dev/null @@ -1,109 +0,0 @@ -% -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 -% -\section{Thin air Ids} - -\begin{code} -module ThinAir ( - thinAirIdNames, -- Names of non-wired-in Ids that may be used out of - setThinAirIds, -- thin air in any compilation. If they are not wired in - -- we must be sure to import them from some Prelude - -- interface file even if they are not overtly - -- mentioned. Subset of builtinNames. - -- Here are the thin-air Ids themselves - addr2IntegerId, - unpackCStringId, unpackCString2Id, - unpackCStringAppendId, unpackCStringFoldrId, - foldrId, buildId, - - noRepIntegerIds, - noRepStrIds - - ) where - -#include "HsVersions.h" - -import Var ( Id, varUnique ) -import Name ( mkKnownKeyGlobal, varName ) -import RdrName ( mkPreludeQual ) -import PrelMods -import UniqFM ( UniqFM, listToUFM, lookupWithDefaultUFM ) -import Unique -import Outputable -import IOExts -\end{code} - - -%************************************************************************ -%* * -\subsection{Thin air entities} -%* * -%************************************************************************ - -These are Ids that we need to reference in various parts of the -system, and we'd like to pull them out of thin air rather than pass -them around. We'd also like to have all the IdInfo available for each -one: i.e. everything that gets pulled out of the interface file. - -The solution is to generate this map of global Ids after the -typechecker, and assign it to a global variable. Any subsequent -pass may refer to the map to pull Ids out. Any invalid -(i.e. pre-typechecker) access to the map will result in a panic. - -\begin{code} -thinAirIdNames - = map mkKnownKeyGlobal - [ - -- Needed for converting literals to Integers (used in tidyCoreExpr) - (varQual pREL_NUM_Name SLIT("addr2Integer"), addr2IntegerIdKey) - - -- Folds and builds; introduced by desugaring list comprehensions - , (varQual pREL_BASE_Name SLIT("unpackNBytes#"), unpackCString2IdKey) - , (varQual pREL_BASE_Name SLIT("unpackCString#"), unpackCStringIdKey) - , (varQual pREL_BASE_Name SLIT("unpackAppendCString#"), unpackCStringAppendIdKey) - , (varQual pREL_BASE_Name SLIT("unpackFoldrCString#"), unpackCStringFoldrIdKey) - - , (varQual pREL_BASE_Name SLIT("foldr"), foldrIdKey) - , (varQual pREL_BASE_Name SLIT("build"), buildIdKey) - ] - -varQual = mkPreludeQual varName -\end{code} - - -\begin{code} -noRepIntegerIds = [addr2IntegerId] - -noRepStrIds = [unpackCString2Id, unpackCStringId] - -addr2IntegerId = lookupThinAirId addr2IntegerIdKey - -unpackCStringId = lookupThinAirId unpackCStringIdKey -unpackCString2Id = lookupThinAirId unpackCString2IdKey -unpackCStringAppendId = lookupThinAirId unpackCStringAppendIdKey -unpackCStringFoldrId = lookupThinAirId unpackCStringFoldrIdKey - -foldrId = lookupThinAirId foldrIdKey -buildId = lookupThinAirId buildIdKey -\end{code} - -\begin{code} -{-# NOINLINE thinAirIdMapRef #-} -thinAirIdMapRef :: IORef (UniqFM Id) -thinAirIdMapRef = unsafePerformIO (newIORef (panic "thinAirIdMap: still empty")) - -setThinAirIds :: [Id] -> IO () -setThinAirIds thin_air_ids - = writeIORef thinAirIdMapRef the_map - where - the_map = listToUFM [(varUnique id, id) | id <- thin_air_ids] - -thinAirIdMap :: UniqFM Id -thinAirIdMap = unsafePerformIO (readIORef thinAirIdMapRef) - -- Read it just once, the first time someone tugs on thinAirIdMap - -lookupThinAirId :: Unique -> Id -lookupThinAirId uniq = lookupWithDefaultUFM thinAirIdMap - (panic "lookupThinAirId: no mapping") uniq -\end{code} - diff --git a/ghc/compiler/prelude/TysPrim.lhs b/ghc/compiler/prelude/TysPrim.lhs index 694492e333..10673367a3 100644 --- a/ghc/compiler/prelude/TysPrim.lhs +++ b/ghc/compiler/prelude/TysPrim.lhs @@ -53,7 +53,7 @@ import Type ( Type, mkTyConApp, mkTyConTy, mkTyVarTys, unboxedTypeKind, boxedTypeKind, openTypeKind, mkArrowKinds ) -import PrelMods ( pREL_GHC ) +import PrelNames ( pREL_GHC ) import Outputable import Unique \end{code} diff --git a/ghc/compiler/prelude/TysWiredIn.lhs b/ghc/compiler/prelude/TysWiredIn.lhs index 7a76a1acc1..a2b6ae3910 100644 --- a/ghc/compiler/prelude/TysWiredIn.lhs +++ b/ghc/compiler/prelude/TysWiredIn.lhs @@ -48,11 +48,9 @@ module TysWiredIn ( -- tuples mkTupleTy, - tupleTyCon, tupleCon, unitTyCon, unitDataConId, pairTyCon, - - -- unboxed tuples - mkUnboxedTupleTy, - unboxedTupleTyCon, unboxedTupleCon, + tupleTyCon, tupleCon, + unitTyCon, unitDataConId, pairTyCon, + unboxedSingletonTyCon, unboxedSingletonDataCon, unboxedPairTyCon, unboxedPairDataCon, stablePtrTyCon, @@ -77,7 +75,7 @@ module TysWiredIn ( import {-# SOURCE #-} MkId( mkDataConId, mkDataConWrapId ) -- friends: -import PrelMods +import PrelNames import TysPrim -- others: @@ -89,7 +87,7 @@ import Var ( TyVar, tyVarKind ) import TyCon ( TyCon, AlgTyConFlavour(..), ArgVrcs, tyConDataCons, mkAlgTyCon, mkSynTyCon, mkTupleTyCon, isUnLiftedTyCon ) -import BasicTypes ( Arity, NewOrData(..), RecFlag(..) ) +import BasicTypes ( Arity, NewOrData(..), RecFlag(..), Boxity(..), isBoxed ) import Type ( Type, mkTyConTy, mkTyConApp, mkSigmaTy, mkTyVarTys, mkArrowKinds, boxedTypeKind, unboxedTypeKind, mkFunTy, mkFunTys, @@ -121,6 +119,7 @@ pcTyCon new_or_data is_rec key mod str tyvars argvrcs cons [] -- No context argvrcs cons + (length cons) [] -- No derivings new_or_data is_rec @@ -165,88 +164,49 @@ pcDataCon wrap_key mod str tyvars context arg_tys tycon %************************************************************************ \begin{code} -tupleTyCon :: Arity -> TyCon -tupleTyCon i | i > mAX_TUPLE_SIZE = fst (mk_tuple i) -- Build one specially - | otherwise = tupleTyConArr!i - -tupleCon :: Arity -> DataCon -tupleCon i | i > mAX_TUPLE_SIZE = snd (mk_tuple i) -- Build one specially - | otherwise = tupleConArr!i - -tupleTyCons :: [TyCon] -tupleTyCons = elems tupleTyConArr - -tupleTyConArr :: Array Int TyCon -tupleTyConArr = array (0,mAX_TUPLE_SIZE) ([0..] `zip` map fst tuples) - -tupleConArr :: Array Int DataCon -tupleConArr = array (0,mAX_TUPLE_SIZE) ([0..] `zip` map snd tuples) - -tuples :: [(TyCon,DataCon)] -tuples = [mk_tuple i | i <- [0..mAX_TUPLE_SIZE]] - -mk_tuple :: Int -> (TyCon,DataCon) -mk_tuple arity = (tycon, tuple_con) +tupleTyCon :: Boxity -> Arity -> TyCon +tupleTyCon boxity i | i > mAX_TUPLE_SIZE = fst (mk_tuple boxity i) -- Build one specially +tupleTyCon Boxed i = fst (boxedTupleArr ! i) +tupleTyCon Unboxed i = fst (unboxedTupleArr ! i) + +tupleCon :: Boxity -> Arity -> DataCon +tupleCon boxity i | i > mAX_TUPLE_SIZE = snd (mk_tuple boxity i) -- Build one specially +tupleCon Boxed i = snd (boxedTupleArr ! i) +tupleCon Unboxed i = snd (unboxedTupleArr ! i) + +boxedTupleArr, unboxedTupleArr :: Array Int (TyCon,DataCon) +boxedTupleArr = array (0,mAX_TUPLE_SIZE) [(i,mk_tuple Boxed i) | i <- [0..mAX_TUPLE_SIZE]] +unboxedTupleArr = array (0,mAX_TUPLE_SIZE) [(i,mk_tuple Unboxed i) | i <- [0..mAX_TUPLE_SIZE]] + +mk_tuple :: Boxity -> Int -> (TyCon,DataCon) +mk_tuple boxity arity = (tycon, tuple_con) where - tycon = mkTupleTyCon tc_name tc_kind arity tyvars tuple_con True + tycon = mkTupleTyCon tc_name tc_kind arity tyvars tuple_con boxity tc_name = mkWiredInTyConName tc_uniq mod name_str tycon - tc_kind = mkArrowKinds (map tyVarKind tyvars) boxedTypeKind + tc_kind = mkArrowKinds (map tyVarKind tyvars) res_kind + res_kind | isBoxed boxity = boxedTypeKind + | otherwise = unboxedTypeKind + + tyvars | isBoxed boxity = take arity alphaTyVars + | otherwise = take arity openAlphaTyVars tuple_con = pcDataCon dc_uniq mod name_str tyvars [] tyvar_tys tycon - tyvars = take arity alphaTyVars tyvar_tys = mkTyVarTys tyvars - (mod_name, name_str) = mkTupNameStr arity - tc_uniq = mkTupleTyConUnique arity - dc_uniq = mkTupleDataConUnique arity + (mod_name, name_str) = mkTupNameStr boxity arity + tc_uniq = mkTupleTyConUnique boxity arity + dc_uniq = mkTupleDataConUnique boxity arity mod = mkPrelModule mod_name -unitTyCon = tupleTyCon 0 +unitTyCon = tupleTyCon Boxed 0 unitDataConId = dataConId (head (tyConDataCons unitTyCon)) -pairTyCon = tupleTyCon 2 -\end{code} +pairTyCon = tupleTyCon Boxed 2 -%************************************************************************ -%* * -\subsection[TysWiredIn-ubx-tuples]{Unboxed Tuple Types} -%* * -%************************************************************************ +unboxedSingletonTyCon = tupleTyCon Unboxed 1 +unboxedSingletonDataCon = tupleCon Unboxed 1 -\begin{code} -unboxedTupleTyCon :: Arity -> TyCon -unboxedTupleTyCon i | i > mAX_TUPLE_SIZE = fst (mk_unboxed_tuple i) - | otherwise = unboxedTupleTyConArr!i - -unboxedTupleCon :: Arity -> DataCon -unboxedTupleCon i | i > mAX_TUPLE_SIZE = snd (mk_unboxed_tuple i) - | otherwise = unboxedTupleConArr!i - -unboxedTupleTyConArr :: Array Int TyCon -unboxedTupleTyConArr = array (0,mAX_TUPLE_SIZE) ([0..] `zip` map fst ubx_tuples) - -unboxedTupleConArr :: Array Int DataCon -unboxedTupleConArr = array (0,mAX_TUPLE_SIZE) ([0..] `zip` map snd ubx_tuples) - -ubx_tuples :: [(TyCon,DataCon)] -ubx_tuples = [mk_unboxed_tuple i | i <- [0..mAX_TUPLE_SIZE]] - -mk_unboxed_tuple :: Int -> (TyCon,DataCon) -mk_unboxed_tuple arity = (tycon, tuple_con) - where - tycon = mkTupleTyCon tc_name tc_kind arity tyvars tuple_con False - tc_name = mkWiredInTyConName tc_uniq mod name_str tycon - tc_kind = mkArrowKinds (map tyVarKind tyvars) unboxedTypeKind - - tuple_con = pcDataCon dc_uniq mod name_str tyvars [] tyvar_tys tycon - tyvars = take arity openAlphaTyVars - tyvar_tys = mkTyVarTys tyvars - (mod_name, name_str) = mkUbxTupNameStr arity - tc_uniq = mkUbxTupleTyConUnique arity - dc_uniq = mkUbxTupleDataConUnique arity - mod = mkPrelModule mod_name - -unboxedPairTyCon = unboxedTupleTyCon 2 -unboxedPairDataCon = unboxedTupleCon 2 +unboxedPairTyCon = tupleTyCon Unboxed 2 +unboxedPairDataCon = tupleCon Unboxed 2 \end{code} %************************************************************************ @@ -589,11 +549,8 @@ done by enumeration\srcloc{lib/prelude/InTup?.hs}. \end{itemize} \begin{code} -mkTupleTy :: Int -> [Type] -> Type -mkTupleTy arity tys = mkTyConApp (tupleTyCon arity) tys - -mkUnboxedTupleTy :: Int -> [Type] -> Type -mkUnboxedTupleTy arity tys = mkTyConApp (unboxedTupleTyCon arity) tys +mkTupleTy :: Boxity -> Int -> [Type] -> Type +mkTupleTy boxity arity tys = mkTyConApp (tupleTyCon boxity arity) tys -unitTy = mkTupleTy 0 [] +unitTy = mkTupleTy Boxed 0 [] \end{code} diff --git a/ghc/compiler/rename/ParseIface.y b/ghc/compiler/rename/ParseIface.y index 8110d2702e..cf0bf83aa8 100644 --- a/ghc/compiler/rename/ParseIface.y +++ b/ghc/compiler/rename/ParseIface.y @@ -1,3 +1,32 @@ +{- Notes about the syntax of interface files + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The header +~~~~~~~~~~ + interface "edison" M 4 6 2 ! 406 Module M, version 4, from package 'edison', + Fixities version 6, rules version 2 + Interface syntax version 406 + ! means M contains orphans + +Import declarations +~~~~~~~~~~~~~~~~~~~ + import Foo ; To compile M I used nothing from Foo, but it's + below me in the hierarchy + + import Foo ! @ ; Ditto, but the ! means that Foo contains orphans + and the @ means that Foo is a boot interface + + import Foo :: 3 ; To compile M I used everything from Foo, which has + module version 3 + + import Foo :: 3 2 6 a 1 b 3 c 7 ; To compile M I used Foo. It had + module version 3 + fixity version 2 + rules version 6 + and some specific things besides. + +-} + + { module ParseIface ( parseIface, IfaceStuff(..) ) where @@ -5,11 +34,12 @@ module ParseIface ( parseIface, IfaceStuff(..) ) where import HsSyn -- quite a bit of stuff import RdrHsSyn -- oodles of synonyms -import HsTypes ( mkHsForAllTy, mkHsUsForAllTy ) +import HsTypes ( mkHsForAllTy, mkHsUsForAllTy, mkHsTupCon ) import HsCore +import Demand ( mkStrictnessInfo ) import Literal ( Literal(..), mkMachInt, mkMachInt64, mkMachWord, mkMachWord64 ) import BasicTypes ( Fixity(..), FixityDirection(..), - NewOrData(..), Version + NewOrData(..), Version, initialVersion, Boxity(..) ) import CostCentre ( CostCentre(..), IsCafCC(..), IsDupdCC(..) ) import CallConv ( cCallConv ) @@ -19,7 +49,7 @@ import IdInfo ( ArityInfo, exactArity, CprInfo(..), InlinePragInfo(..) import PrimOp ( CCall(..), CCallTarget(..) ) import Lex -import RnMonad ( ImportVersion, LocalVersion, ParsedIface(..), WhatsImported(..), +import RnMonad ( ImportVersion, ParsedIface(..), WhatsImported(..), RdrNamePragma, ExportItem, RdrAvailInfo, GenAvailInfo(..), WhetherHasOrphans, IsBootInterface ) @@ -32,11 +62,11 @@ import OccName ( mkSysOccFS, EncodedFS ) import Module ( ModuleName, PackageName, mkSysModuleFS, mkModule ) -import PrelInfo ( mkTupConRdrName, mkUbxTupConRdrName ) import SrcLoc ( SrcLoc ) import CmdLineOpts ( opt_InPackage ) import Maybes import Outputable +import List ( insert ) import GlaExts import FastString ( tailFS ) @@ -184,36 +214,42 @@ iface_stuff : iface { PIface $1 } iface :: { ParsedIface } -iface : '__interface' package mod_name INTEGER orphans checkVersion 'where' +iface : '__interface' package mod_name + version sub_versions + orphans checkVersion 'where' exports_part import_part + fix_decl_part instance_decl_part decls_part rules_and_deprecs { ParsedIface { pi_mod = mkModule $3 $2, -- Module itself - pi_vers = fromInteger $4, -- Module version - pi_orphan = $5, - pi_exports = $8, -- Exports - pi_usages = $9, -- Usages - pi_insts = $10, -- Local instances - pi_decls = $11, -- Decls - pi_rules = fst $12, -- Rules - pi_deprecs = snd $12 -- Deprecations - } } + pi_vers = $4, -- Module version + pi_orphan = $6, + pi_exports = $9, -- Exports + pi_usages = $10, -- Usages + pi_fixity = (fst $5,$11), -- Fixies + pi_insts = $12, -- Local instances + pi_decls = $13, -- Decls + pi_rules = (snd $5,fst $14), -- Rules + pi_deprecs = snd $14 -- Deprecations + } } + +-- Versions for fixities and rules (optional) +sub_versions :: { (Version,Version) } + : '[' version version ']' { ($2,$3) } + | {- empty -} { (initialVersion, initialVersion) } -------------------------------------------------------------------------- import_part :: { [ImportVersion OccName] } import_part : { [] } - | import_part import_decl { $2 : $1 } + | import_decl import_part { $1 : $2 } import_decl :: { ImportVersion OccName } -import_decl : 'import' mod_name INTEGER orphans is_boot whats_imported ';' - { (mkSysModuleFS $2, fromInteger $3, $4, $5, $6) } - -- import Foo 3 :: a 1 b 3 c 7 ; means import a,b,c from Foo - -- import Foo 3 ; means import all of Foo - -- import Foo 3 ! :: ...stuff... ; the ! means that Foo contains orphans +import_decl : 'import' mod_name orphans is_boot whats_imported ';' + { (mkSysModuleFS $2, $3, $4, $5) } orphans :: { WhetherHasOrphans } orphans : { False } @@ -224,34 +260,39 @@ is_boot : { False } | '@' { True } whats_imported :: { WhatsImported OccName } -whats_imported : { Everything } - | '::' name_version_pairs { Specifically $2 } +whats_imported : { NothingAtAll } + | '::' version { Everything $2 } + | '::' version version version name_version_pairs { Specifically $2 $3 $4 $5 } -name_version_pairs :: { [LocalVersion OccName] } +name_version_pairs :: { [(OccName, Version)] } name_version_pairs : { [] } | name_version_pair name_version_pairs { $1 : $2 } -name_version_pair :: { LocalVersion OccName } -name_version_pair : var_occ INTEGER { ($1, fromInteger $2) } - | tc_occ INTEGER { ($1, fromInteger $2) } +name_version_pair :: { (OccName, Version) } +name_version_pair : var_occ version { ($1, $2) } + | tc_occ version { ($1, $2) } -------------------------------------------------------------------------- exports_part :: { [ExportItem] } exports_part : { [] } - | exports_part '__export' - mod_name entities ';' { (mkSysModuleFS $3, $4) : $1 } + | '__export' mod_name entities ';' + exports_part { (mkSysModuleFS $2, $3) : $5 } entities :: { [RdrAvailInfo] } entities : { [] } | entity entities { $1 : $2 } entity :: { RdrAvailInfo } -entity : tc_occ { AvailTC $1 [$1] } - | var_occ { Avail $1 } - | tc_occ stuff_inside { AvailTC $1 ($1:$2) } +entity : var_occ { Avail $1 } + | tc_occ { AvailTC $1 [$1] } | tc_occ '|' stuff_inside { AvailTC $1 $3 } + | tc_occ stuff_inside { AvailTC $1 (insert $1 $2) } + -- The 'insert' is important. The stuff_inside is sorted, and + -- insert keeps it that way. This is important when comparing + -- against the new interface file, which has the stuff in sorted order + -- If they differ, we'll bump the module number when it's unnecessary stuff_inside :: { [OccName] } stuff_inside : '{' val_occs '}' { $2 } @@ -267,14 +308,24 @@ val_occs :: { [OccName] } -------------------------------------------------------------------------- +fix_decl_part :: { [RdrNameFixitySig] } +fix_decl_part : {- empty -} { [] } + | fix_decls ';' { $1 } + +fix_decls :: { [RdrNameFixitySig] } +fix_decls : { [] } + | fix_decl fix_decls { $1 : $2 } + +fix_decl :: { RdrNameFixitySig } +fix_decl : src_loc fixity prec var_or_data_name { FixitySig $4 (Fixity $3 $2) $1 } + fixity :: { FixityDirection } fixity : 'infixl' { InfixL } | 'infixr' { InfixR } | 'infix' { InfixN } -mb_fix :: { Int } -mb_fix : {-nothing-} { 9 } - | INTEGER { (fromInteger $1) } +prec :: { Int } +prec : INTEGER { fromInteger $1 } ----------------------------------------------------------------------------- @@ -283,7 +334,7 @@ csigs : { [] } | 'where' '{' csigs1 '}' { $3 } csigs1 :: { [RdrNameSig] } -csigs1 : csig { [$1] } +csigs1 : { [] } | csig ';' csigs1 { $1 : $3 } csig :: { RdrNameSig } @@ -310,22 +361,20 @@ inst_decl : src_loc 'instance' type '=' var_name ';' decls_part :: { [(Version, RdrNameHsDecl)] } decls_part : {- empty -} { [] } - | decls_part version decl ';' { ($2,$3):$1 } + | opt_version decl ';' decls_part { ($1,$2):$4 } decl :: { RdrNameHsDecl } decl : src_loc var_name '::' type maybe_idinfo { SigD (IfaceSig $2 $4 ($5 $2) $1) } | src_loc 'type' tc_name tv_bndrs '=' type { TyClD (TySynonym $3 $4 $6 $1) } - | src_loc 'data' decl_context tc_name tv_bndrs constrs - { TyClD (TyData DataType $3 $4 $5 $6 Nothing noDataPragmas $1) } - | src_loc 'newtype' decl_context tc_name tv_bndrs newtype_constr - { TyClD (TyData NewType $3 $4 $5 $6 Nothing noDataPragmas $1) } - | src_loc 'class' decl_context tc_name tv_bndrs fds csigs + | src_loc 'data' opt_decl_context tc_name tv_bndrs constrs + { TyClD (TyData DataType $3 $4 $5 $6 (length $6) Nothing noDataPragmas $1) } + | src_loc 'newtype' opt_decl_context tc_name tv_bndrs newtype_constr + { TyClD (TyData NewType $3 $4 $5 $6 1 Nothing noDataPragmas $1) } + | src_loc 'class' opt_decl_context tc_name tv_bndrs fds csigs { TyClD (mkClassDecl $3 $4 $5 $6 $7 EmptyMonoBinds noClassPragmas $1) } - | src_loc fixity mb_fix var_or_data_name - { FixD (FixitySig $4 (Fixity $3 $2) $1) } maybe_idinfo :: { RdrName -> [HsIdInfo RdrName] } maybe_idinfo : {- empty -} { \_ -> [] } @@ -371,7 +420,7 @@ rules :: { [RdrNameRuleDecl] } rule :: { RdrNameRuleDecl } rule : src_loc STRING rule_forall qvar_name - core_args '=' core_expr { IfaceRuleDecl $4 (UfRuleBody $2 $3 $5 $7) $1 } + core_args '=' core_expr { IfaceRule $2 $3 $4 $5 $7 $1 } rule_forall :: { [UfBinder RdrName] } rule_forall : '__forall' '{' core_bndrs '}' { $3 } @@ -380,11 +429,11 @@ rule_forall : '__forall' '{' core_bndrs '}' { $3 } deprecs :: { [RdrNameDeprecation] } deprecs : {- empty -} { [] } - | deprecs deprec ';' { $2 : $1 } + | deprec ';' deprecs { $1 : $3 } deprec :: { RdrNameDeprecation } -deprec : STRING { Deprecation (IEModuleContents undefined) $1 } - | deprec_name STRING { Deprecation $1 $2 } +deprec : src_loc STRING { Deprecation (IEModuleContents undefined) $2 $1 } + | src_loc deprec_name STRING { Deprecation $2 $3 $1 } -- SUP: TEMPORARY HACK deprec_name :: { RdrNameIE } @@ -394,11 +443,15 @@ deprec_name :: { RdrNameIE } ----------------------------------------------------------------------------- version :: { Version } -version : INTEGER { fromInteger $1 } +version : INTEGER { fromInteger $1 } -decl_context :: { RdrNameContext } -decl_context : { [] } - | '{' context_list1 '}' '=>' { $2 } +opt_version :: { Version } +opt_version : version { $1 } + | {- empty -} { initialVersion } + +opt_decl_context :: { RdrNameContext } +opt_decl_context : { [] } + | context '=>' { $1 } ---------------------------------------------------------------------------- @@ -421,9 +474,9 @@ newtype_constr : { [] } | src_loc '=' ex_stuff data_name '{' var_name '::' atype '}' { [mk_con_decl $4 $3 (NewCon $8 (Just $6)) $1] } -ex_stuff :: { ([HsTyVar RdrName], RdrNameContext) } +ex_stuff :: { ([HsTyVarBndr RdrName], RdrNameContext) } ex_stuff : { ([],[]) } - | '__forall' forall context '=>' { ($2,$3) } + | '__forall' tv_bndrs opt_context '=>' { ($2,$3) } batypes :: { [RdrNameBangType] } batypes : { [] } @@ -446,20 +499,21 @@ field : var_names1 '::' type { ($1, Unbanged $3) } type :: { RdrNameHsType } type : '__fuall' fuall '=>' type { mkHsUsForAllTy $2 $4 } - | '__forall' forall context '=>' type - { mkHsForAllTy (Just $2) $3 $5 } - | btype '->' type { MonoFunTy $1 $3 } + | '__forall' tv_bndrs + opt_context '=>' type { mkHsForAllTy (Just $2) $3 $5 } + | btype '->' type { HsFunTy $1 $3 } | btype { $1 } fuall :: { [RdrName] } fuall : '[' uv_bndrs ']' { $2 } -forall :: { [HsTyVar RdrName] } -forall : '[' tv_bndrs ']' { $2 } +opt_context :: { RdrNameContext } +opt_context : { [] } + | context { $1 } context :: { RdrNameContext } -context : { [] } - | '{' context_list1 '}' { $2 } +context : '(' context_list1 ')' { $2 } + | '{' context_list1 '}' { $2 } -- Backward compatibility context_list1 :: { RdrNameContext } context_list1 : class { [$1] } @@ -480,27 +534,25 @@ types2 : type ',' type { [$1,$3] } btype :: { RdrNameHsType } btype : atype { $1 } - | btype atype { MonoTyApp $1 $2 } - | '__u' usage atype { MonoUsgTy $2 $3 } + | btype atype { HsAppTy $1 $2 } + | '__u' usage atype { HsUsgTy $2 $3 } -usage :: { MonoUsageAnn RdrName } -usage : '-' { MonoUsOnce } - | '!' { MonoUsMany } - | uv_name { MonoUsVar $1 } +usage :: { HsUsageAnn RdrName } +usage : '-' { HsUsOnce } + | '!' { HsUsMany } + | uv_name { HsUsVar $1 } atype :: { RdrNameHsType } -atype : qtc_name { MonoTyVar $1 } - | tv_name { MonoTyVar $1 } - | '(' types2 ')' { MonoTupleTy $2 True{-boxed-} } - | '(#' types0 '#)' { MonoTupleTy $2 False{-unboxed-} } - | '[' type ']' { MonoListTy $2 } - | '{' qcls_name atypes '}' { MonoDictTy $2 $3 } - | '{' ipvar_name '::' type '}' { MonoIParamTy $2 $4 } +atype : qtc_name { HsTyVar $1 } + | tv_name { HsTyVar $1 } + | '(' ')' { HsTupleTy (mkHsTupCon tcName Boxed []) [] } + | '(' types2 ')' { HsTupleTy (mkHsTupCon tcName Boxed $2) $2 } + | '(#' types0 '#)' { HsTupleTy (mkHsTupCon tcName Unboxed $2) $2 } + | '[' type ']' { HsListTy $2 } + | '{' qcls_name atypes '}' { mkHsDictTy $2 $3 } + | '{' ipvar_name '::' type '}' { mkHsIParamTy $2 $4 } | '(' type ')' { $2 } --- This one is dealt with via qtc_name --- | '(' ')' { MonoTupleTy [] True } - atypes :: { [RdrNameHsType] {- Zero or more -} } atypes : { [] } | atype atypes { $1 : $2 } @@ -626,13 +678,17 @@ tv_name :: { RdrName } : VARID { mkSysUnqual tvName $1 } | VARSYM { mkSysUnqual tvName $1 {- Allow t2 as a tyvar -} } -tv_bndr :: { HsTyVar RdrName } +tv_bndr :: { HsTyVarBndr RdrName } : tv_name '::' akind { IfaceTyVar $1 $3 } | tv_name { IfaceTyVar $1 boxedTypeKind } -tv_bndrs :: { [HsTyVar RdrName] } +tv_bndrs :: { [HsTyVarBndr RdrName] } +tv_bndrs : tv_bndrs1 { $1 } + | '[' tv_bndrs1 ']' { $2 } -- Backward compatibility + +tv_bndrs1 :: { [HsTyVarBndr RdrName] } : { [] } - | tv_bndr tv_bndrs { $1 : $2 } + | tv_bndr tv_bndrs1 { $1 : $2 } --------------------------------------------------- fds :: { [([RdrName], [RdrName])] } @@ -674,15 +730,21 @@ id_info_item :: { HsIdInfo RdrName } : '__A' INTEGER { HsArity (exactArity (fromInteger $2)) } | '__U' inline_prag core_expr { HsUnfold $2 $3 } | '__M' { HsCprInfo } - | '__S' { HsStrictness (HsStrictnessInfo $1) } + | '__S' { HsStrictness (mkStrictnessInfo $1) } | '__C' { HsNoCafRefs } | '__P' qvar_name { HsWorker $2 } inline_prag :: { InlinePragInfo } : {- empty -} { NoInlinePragInfo } - | '[' INTEGER ']' { IMustNotBeINLINEd True (Just (fromInteger $2)) } -- INLINE n - | '[' '!' ']' { IMustNotBeINLINEd True Nothing } -- NOTINLINE - | '[' '!' INTEGER ']' { IMustNotBeINLINEd False (Just (fromInteger $3)) } -- NOINLINE n + | '[' from_prag phase ']' { IMustNotBeINLINEd $2 $3 } + +from_prag :: { Bool } + : {- empty -} { True } + | '!' { False } + +phase :: { Maybe Int } + : {- empty -} { Nothing } + | INTEGER { Just (fromInteger $1) } ------------------------------------------------------- core_expr :: { UfExpr RdrName } @@ -697,14 +759,14 @@ core_expr : '\\' core_bndrs '->' core_expr { foldr UfLam $4 $2 } | '__litlit' STRING atype { UfLitLit $2 $3 } - | '__inline_me' core_expr { UfNote UfInlineMe $2 } - | '__inline_call' core_expr { UfNote UfInlineCall $2 } - | '__coerce' atype core_expr { UfNote (UfCoerce $2) $3 } - | scc core_expr { UfNote (UfSCC $1) $2 } | fexpr { $1 } fexpr :: { UfExpr RdrName } fexpr : fexpr core_arg { UfApp $1 $2 } + | scc core_aexpr { UfNote (UfSCC $1) $2 } + | '__inline_me' core_aexpr { UfNote UfInlineMe $2 } + | '__inline_call' core_aexpr { UfNote UfInlineCall $2 } + | '__coerce' atype core_aexpr { UfNote (UfCoerce $2) $3 } | core_aexpr { $1 } core_arg :: { UfExpr RdrName } @@ -718,25 +780,13 @@ core_args :: { [UfExpr RdrName] } core_aexpr :: { UfExpr RdrName } -- Atomic expressions core_aexpr : qvar_name { UfVar $1 } | qdata_name { UfVar $1 } - -- This one means that e.g. "True" will parse as - -- (UfVar True_Id) rather than (UfCon True_Con []). - -- No big deal; it'll be inlined in a jiffy. I tried - -- parsing it to (Con con []) directly, but got bitten - -- when a real constructor Id showed up in an interface - -- file. As usual, a hack bites you in the end. - -- If you want to get a UfCon, then use the - -- curly-bracket notation (True {}). - --- This one is dealt with by qdata_name: see above comments --- | '(' ')' { UfTuple (mkTupConRdrName 0) [] } | core_lit { UfLit $1 } | '(' core_expr ')' { $2 } - -- Tuple construtors are for the *worker* of the tuple - -- Going direct saves needless messing about - | '(' comma_exprs2 ')' { UfTuple (mkRdrNameWkr (mkTupConRdrName (length $2))) $2 } - | '(#' comma_exprs0 '#)' { UfTuple (mkRdrNameWkr (mkUbxTupConRdrName (length $2))) $2 } + | '(' ')' { UfTuple (mkHsTupCon dataName Boxed []) [] } + | '(' comma_exprs2 ')' { UfTuple (mkHsTupCon dataName Boxed $2) $2 } + | '(#' comma_exprs0 '#)' { UfTuple (mkHsTupCon dataName Unboxed $2) $2 } | '{' '__ccall' ccall_string type '}' { let @@ -765,7 +815,7 @@ rec_binds :: { [(UfBinder RdrName, UfExpr RdrName)] } | core_val_bndr '=' core_expr ';' rec_binds { ($1,$3) : $5 } core_alts :: { [UfAlt RdrName] } - : core_alt { [$1] } + : { [] } | core_alt ';' core_alts { $1 : $3 } core_alt :: { UfAlt RdrName } @@ -775,8 +825,9 @@ core_pat :: { (UfConAlt RdrName, [RdrName]) } core_pat : core_lit { (UfLitAlt $1, []) } | '__litlit' STRING atype { (UfLitLitAlt $2 $3, []) } | qdata_name core_pat_names { (UfDataAlt $1, $2) } - | '(' comma_var_names1 ')' { (UfDataAlt (mkTupConRdrName (length $2)), $2) } - | '(#' comma_var_names1 '#)' { (UfDataAlt (mkUbxTupConRdrName (length $2)), $2) } + | '(' ')' { (UfTupleAlt (mkHsTupCon dataName Boxed []), []) } + | '(' comma_var_names1 ')' { (UfTupleAlt (mkHsTupCon dataName Boxed $2), $2) } + | '(#' comma_var_names1 '#)' { (UfTupleAlt (mkHsTupCon dataName Unboxed $2), $2) } | '__DEFAULT' { (UfDefault, []) } | '(' core_pat ')' { $2 } @@ -860,6 +911,9 @@ cc_caf :: { IsCafCC } src_loc :: { SrcLoc } src_loc : {% getSrcLocP } +-- Check the project version: this makes sure +-- that the project version (e.g. 407) in the interface +-- file is the same as that for the compiler that's reading it checkVersion :: { () } : {-empty-} {% checkVersion Nothing } | INTEGER {% checkVersion (Just (fromInteger $1)) } diff --git a/ghc/compiler/rename/Rename.lhs b/ghc/compiler/rename/Rename.lhs index ee176e6af0..58adc32f1d 100644 --- a/ghc/compiler/rename/Rename.lhs +++ b/ghc/compiler/rename/Rename.lhs @@ -9,24 +9,27 @@ module Rename ( renameModule ) where #include "HsVersions.h" import HsSyn -import RdrHsSyn ( RdrNameHsModule ) +import HsPragmas ( DataPragmas(..) ) +import RdrHsSyn ( RdrNameHsModule, RdrNameHsDecl, RdrNameDeprecation ) import RnHsSyn ( RenamedHsModule, RenamedHsDecl, extractHsTyNames, extractHsCtxtTyNames ) import CmdLineOpts ( opt_HiMap, opt_D_dump_rn_trace, opt_D_dump_minimal_imports, - opt_D_dump_rn, opt_D_dump_rn_stats, opt_WarnDeprecations + opt_D_dump_rn, opt_D_dump_rn_stats, opt_WarnDeprecations, + opt_WarnUnusedBinds ) import RnMonad import RnNames ( getGlobalNames ) import RnSource ( rnSourceDecls, rnDecl ) -import RnIfaces ( getImportedInstDecls, importDecl, getImportVersions, getInterfaceExports, - getImportedRules, loadHomeInterface, getSlurped, removeContext +import RnIfaces ( getImportedInstDecls, importDecl, mkImportExportInfo, getInterfaceExports, + getImportedRules, loadHomeInterface, getSlurped, removeContext, + loadBuiltinRules, getDeferredDecls, ImportDeclResult(..) ) import RnEnv ( availName, availsToNameSet, unitAvailEnv, availEnvElts, plusAvailEnv, warnUnusedImports, warnUnusedLocalBinds, warnUnusedModules, - lookupImplicitOccRn, pprAvail, - FreeVars, plusFVs, plusFV, unitFV, emptyFVs, isEmptyFVs + lookupImplicitOccsRn, pprAvail, unknownNameErr, + FreeVars, plusFVs, plusFV, unitFV, emptyFVs, isEmptyFVs, addOneFV ) import Module ( Module, ModuleName, WhereFrom(..), moduleNameUserString, mkSearchPath, moduleName, mkThisModule @@ -34,22 +37,27 @@ import Module ( Module, ModuleName, WhereFrom(..), import Name ( Name, isLocallyDefined, NamedThing(..), getSrcLoc, nameOccName, nameUnique, nameModule, maybeUserImportedFrom, isUserImportedExplicitlyName, isUserImportedName, - maybeWiredInTyConName, maybeWiredInIdName, isWiredInName + maybeWiredInTyConName, maybeWiredInIdName, isWiredInName, + isUserExportedName, toRdrName ) import OccName ( occNameFlavour, isValOcc ) import Id ( idType ) import TyCon ( isSynTyCon, getSynTyConDefn ) import NameSet -import PrelMods ( mAIN_Name, pREL_MAIN_Name, pRELUDE_Name ) import TysWiredIn ( unitTyCon, intTyCon, doubleTyCon, boolTyCon ) -import PrelInfo ( ioTyCon_NAME, thinAirIdNames, fractionalClassKeys, derivingOccurrences ) +import PrelRules ( builtinRules ) +import PrelInfo ( mAIN_Name, pREL_MAIN_Name, pRELUDE_Name, + ioTyCon_RDR, unpackCString_RDR, unpackCString2_RDR, unpackCStringFoldr_RDR, + fractionalClassKeys, derivingOccurrences + ) import Type ( namesOfType, funTyCon ) import ErrUtils ( printErrorsAndWarnings, dumpIfSet, ghcExit ) -import BasicTypes ( NewOrData(..) ) +import BasicTypes ( Version, initialVersion ) import Bag ( isEmptyBag, bagToList ) import FiniteMap ( FiniteMap, eltsFM, fmToList, emptyFM, lookupFM, addToFM_C ) import UniqSupply ( UniqSupply ) import UniqFM ( lookupUFM ) +import SrcLoc ( noSrcLoc ) import Maybes ( maybeToBool, expectJust ) import Outputable import IO ( openFile, IOMode(..) ) @@ -58,124 +66,138 @@ import IO ( openFile, IOMode(..) ) \begin{code} -renameModule :: UniqSupply - -> RdrNameHsModule - -> IO (Maybe - ( Module - , RenamedHsModule -- Output, after renaming - , InterfaceDetails -- Interface; for interface file generation - , RnNameSupply -- Final env; for renaming derivings - , [ModuleName] -- Imported modules; for profiling - )) - +type RenameResult = ( Module -- This module + , RenamedHsModule -- Renamed module + , Maybe ParsedIface -- The existing interface file, if any + , ParsedIface -- The new interface + , RnNameSupply -- Final env; for renaming derivings + , FixityEnv -- The fixity environment; for derivings + , [ModuleName]) -- Imported modules; for profiling + +renameModule :: UniqSupply -> RdrNameHsModule -> IO (Maybe RenameResult) renameModule us this_mod@(HsModule mod_name vers exports imports local_decls _ loc) = -- Initialise the renamer monad - initRn mod_name us (mkSearchPath opt_HiMap) loc - (rename this_mod) >>= - \ ((maybe_rn_stuff, dump_action), rn_errs_bag, rn_warns_bag) -> + do { + ((maybe_rn_stuff, dump_action), rn_errs_bag, rn_warns_bag) + <- initRn mod_name us (mkSearchPath opt_HiMap) loc (rename this_mod) ; -- Check for warnings - printErrorsAndWarnings rn_errs_bag rn_warns_bag >> + printErrorsAndWarnings rn_errs_bag rn_warns_bag ; -- Dump any debugging output - dump_action >> + dump_action ; -- Return results - if not (isEmptyBag rn_errs_bag) then - ghcExit 1 >> return Nothing - else + if not (isEmptyBag rn_errs_bag) then + do { ghcExit 1 ; return Nothing } + else return maybe_rn_stuff + } \end{code} - \begin{code} -rename :: RdrNameHsModule - -> RnMG (Maybe (Module, RenamedHsModule, InterfaceDetails, RnNameSupply, [ModuleName]), IO ()) -rename this_mod@(HsModule mod_name vers _ imports local_decls mod_deprec loc) +rename :: RdrNameHsModule -> RnMG (Maybe RenameResult, IO ()) +rename this_mod@(HsModule mod_name vers exports imports local_decls mod_deprec loc) = -- FIND THE GLOBAL NAME ENVIRONMENT getGlobalNames this_mod `thenRn` \ maybe_stuff -> -- CHECK FOR EARLY EXIT - if not (maybeToBool maybe_stuff) then - -- Everything is up to date; no need to recompile further - rnDump [] [] `thenRn` \ dump_action -> - returnRn (Nothing, dump_action) - else - let - Just (export_env, gbl_env, fixity_env, global_avail_env) = maybe_stuff - ExportEnv export_avails _ _ = export_env - in + case maybe_stuff of { + Nothing -> -- Everything is up to date; no need to recompile further + rnDump [] [] `thenRn` \ dump_action -> + returnRn (Nothing, dump_action) ; + + Just (gbl_env, local_gbl_env, export_avails, global_avail_env, old_iface) -> + + -- DEAL WITH DEPRECATIONS + rnDeprecs local_gbl_env mod_deprec local_decls `thenRn` \ my_deprecs -> + + -- DEAL WITH LOCAL FIXITIES + fixitiesFromLocalDecls local_gbl_env local_decls `thenRn` \ local_fixity_env -> -- RENAME THE SOURCE - initRnMS gbl_env fixity_env SourceMode ( + initRnMS gbl_env local_fixity_env SourceMode ( rnSourceDecls local_decls ) `thenRn` \ (rn_local_decls, source_fvs) -> -- SLURP IN ALL THE NEEDED DECLARATIONS implicitFVs mod_name rn_local_decls `thenRn` \ implicit_fvs -> let - real_source_fvs = implicit_fvs `plusFV` source_fvs `plusFV` export_fvs - -- It's important to do the "plus" this way round, so that - -- when compiling the prelude, locally-defined (), Bool, etc - -- override the implicit ones. - -- The export_fvs make the exported names look just as if they -- occurred in the source program. For the reasoning, see the - -- comments with RnIfaces.getImportVersions - export_fvs = mkNameSet (map availName export_avails) - in - slurpImpDecls real_source_fvs `thenRn` \ rn_imp_decls -> - let - rn_all_decls = rn_local_decls ++ rn_imp_decls + -- comments with RnIfaces.getImportVersions. + -- We only need the 'parent name' of the avail; + -- that's enough to suck in the declaration. + export_fvs = mkNameSet (map availName export_avails) + real_source_fvs = source_fvs `plusFV` export_fvs - -- COLLECT ALL DEPRECATIONS - deprec_sigs = [ ds | ValD bnds <- rn_local_decls, ds <- collectDeprecs bnds ] - deprecs = case mod_deprec of - Nothing -> deprec_sigs - Just txt -> Deprecation (IEModuleContents undefined) txt : deprec_sigs + slurp_fvs = implicit_fvs `plusFV` real_source_fvs + -- It's important to do the "plus" this way round, so that + -- when compiling the prelude, locally-defined (), Bool, etc + -- override the implicit ones. in + loadBuiltinRules builtinRules `thenRn_` + slurpImpDecls slurp_fvs `thenRn` \ rn_imp_decls -> -- EXIT IF ERRORS FOUND + rnDump rn_imp_decls rn_local_decls `thenRn` \ dump_action -> checkErrsRn `thenRn` \ no_errs_so_far -> if not no_errs_so_far then -- Found errors already, so exit now - rnDump rn_imp_decls rn_all_decls `thenRn` \ dump_action -> returnRn (Nothing, dump_action) else -- GENERATE THE VERSION/USAGE INFO - getImportVersions mod_name export_env `thenRn` \ my_usages -> - getNameSupplyRn `thenRn` \ name_supply -> + mkImportExportInfo mod_name export_avails exports `thenRn` \ (my_exports, my_usages) -> -- RETURN THE RENAMED MODULE + getNameSupplyRn `thenRn` \ name_supply -> let - has_orphans = any isOrphanDecl rn_local_decls + this_module = mkThisModule mod_name direct_import_mods = [mod | ImportDecl mod _ _ _ _ _ <- imports] + + -- Export only those fixities that are for names that are + -- (a) defined in this module + -- (b) exported + exported_fixities + = [ FixitySig (toRdrName name) fixity loc + | FixitySig name fixity loc <- nameEnvElts local_fixity_env, + isUserExportedName name + ] + + new_iface = ParsedIface { pi_mod = this_module + , pi_vers = initialVersion + , pi_orphan = any isOrphanDecl rn_local_decls + , pi_exports = my_exports + , pi_usages = my_usages + , pi_fixity = (initialVersion, exported_fixities) + , pi_deprecs = my_deprecs + -- These ones get filled in later + , pi_insts = [], pi_decls = [] + , pi_rules = (initialVersion, []) + } + renamed_module = HsModule mod_name vers trashed_exports trashed_imports - rn_all_decls + (rn_local_decls ++ rn_imp_decls) mod_deprec loc + + result = (this_module, renamed_module, + old_iface, new_iface, + name_supply, local_fixity_env, + direct_import_mods) in + -- REPORT UNUSED NAMES, AND DEBUG DUMP reportUnusedNames mod_name direct_import_mods gbl_env global_avail_env - export_env - source_fvs `thenRn_` - rnDump rn_imp_decls rn_all_decls `thenRn` \ dump_action -> - - returnRn (Just (mkThisModule mod_name, - renamed_module, - (InterfaceDetails has_orphans my_usages export_env deprecs), - name_supply, - direct_import_mods), dump_action) + export_avails source_fvs `thenRn_` + + returnRn (Just result, dump_action) } where trashed_exports = {-trace "rnSource:trashed_exports"-} Nothing trashed_imports = {-trace "rnSource:trashed_imports"-} [] - - collectDeprecs EmptyBinds = [] - collectDeprecs (ThenBinds x y) = collectDeprecs x ++ collectDeprecs y - collectDeprecs (MonoBind _ sigs _) = [ d | DeprecSig d _ <- sigs ] \end{code} @implicitFVs@ forces the renamer to slurp in some things which aren't @@ -183,11 +205,9 @@ mentioned explicitly, but which might be needed by the type checker. \begin{code} implicitFVs mod_name decls - = mapRn lookupImplicitOccRn implicit_occs `thenRn` \ implicit_names -> - returnRn (implicit_main `plusFV` - mkNameSet (map getName default_tycons) `plusFV` - mkNameSet thinAirIdNames `plusFV` - mkNameSet implicit_names) + = lookupImplicitOccsRn implicit_occs `thenRn` \ implicit_names -> + returnRn (mkNameSet (map getName default_tycons) `plusFV` + implicit_names) where -- Add occurrences for Int, and (), because they -- are the types to which ambigious type variables may be defaulted by @@ -201,15 +221,18 @@ implicitFVs mod_name decls -- Add occurrences for IO or PrimIO implicit_main | mod_name == mAIN_Name - || mod_name == pREL_MAIN_Name = unitFV ioTyCon_NAME - | otherwise = emptyFVs + || mod_name == pREL_MAIN_Name = [ioTyCon_RDR] + | otherwise = [] -- Now add extra "occurrences" for things that -- the deriving mechanism, or defaulting, will later need in order to -- generate code - implicit_occs = foldr ((++) . get) [] decls + implicit_occs = string_occs ++ foldr ((++) . get) implicit_main decls + + -- Virtually every program has error messages in it somewhere + string_occs = [unpackCString_RDR, unpackCString2_RDR, unpackCStringFoldr_RDR] - get (TyClD (TyData _ _ _ _ _ (Just deriv_classes) _ _)) + get (TyClD (TyData _ _ _ _ _ _ (Just deriv_classes) _ _)) = concat (map get_deriv deriv_classes) get other = [] @@ -226,7 +249,7 @@ isOrphanDecl (InstD (InstDecl inst_ty _ _ _ _)) -- The decl is an orphan if Baz and T are both not locally defined, -- even if Foo *is* locally defined -isOrphanDecl (RuleD (RuleDecl _ _ _ lhs _ _)) +isOrphanDecl (RuleD (HsRule _ _ _ lhs _ _)) = check lhs where -- At the moment we just check for common LHS forms @@ -273,8 +296,13 @@ slurpImpDecls source_fvs getSlurped `thenRn` \ source_binders -> slurpSourceRefs source_binders source_fvs `thenRn` \ (decls, needed) -> - -- And finally get everything else - closeDecls decls needed + -- Then get everything else + closeDecls decls needed `thenRn` \ decls1 -> + + -- Finally, get any deferred data type decls + slurpDeferredDecls decls1 `thenRn` \ final_decls -> + + returnRn final_decls ------------------------------------------------------- slurpSourceRefs :: NameSet -- Variables defined in source @@ -309,7 +337,7 @@ slurpSourceRefs source_binders source_fvs go_outer decls fvs all_gates refs -- refs are not necessarily slurped yet = traceRn (text "go_outer" <+> ppr refs) `thenRn_` - go_inner decls fvs emptyFVs refs `thenRn` \ (decls1, fvs1, gates1) -> + foldlRn go_inner (decls, fvs, emptyFVs) refs `thenRn` \ (decls1, fvs1, gates1) -> getImportedInstDecls (all_gates `plusFV` gates1) `thenRn` \ inst_decls -> rnInstDecls decls1 fvs1 gates1 inst_decls `thenRn` \ (decls2, fvs2, gates2) -> go_outer decls2 fvs2 (all_gates `plusFV` gates2) @@ -317,39 +345,17 @@ slurpSourceRefs source_binders source_fvs -- Knock out the all_gates because even if we don't slurp any new -- decls we can get some apparently-new gates from wired-in names - go_inner decls fvs gates [] - = returnRn (decls, fvs, gates) - - go_inner decls fvs gates (wanted_name:refs) - | isWiredInName wanted_name - = load_home wanted_name `thenRn_` - go_inner decls fvs (gates `plusFV` getWiredInGates wanted_name) refs - - | otherwise - = importDecl wanted_name `thenRn` \ maybe_decl -> - case maybe_decl of - Nothing -> go_inner decls fvs gates refs -- No declaration... (already slurped, or local) - Just decl -> rnIfaceDecl decl `thenRn` \ (new_decl, fvs1) -> - go_inner (new_decl : decls) - (fvs1 `plusFV` fvs) - (gates `plusFV` getGates source_fvs new_decl) - refs - - -- When we find a wired-in name we must load its - -- home module so that we find any instance decls therein - load_home name - | name `elemNameSet` source_binders = returnRn () - -- When compiling the prelude, a wired-in thing may - -- be defined in this module, in which case we don't - -- want to load its home module! - -- Using 'isLocallyDefined' doesn't work because some of - -- the free variables returned are simply 'listTyCon_Name', - -- with a system provenance. We could look them up every time - -- but that seems a waste. - | otherwise = loadHomeInterface doc name `thenRn_` - returnRn () - where - doc = ptext SLIT("need home module for wired in thing") <+> ppr name + go_inner (decls, fvs, gates) wanted_name + = importDecl wanted_name `thenRn` \ import_result -> + case import_result of + AlreadySlurped -> returnRn (decls, fvs, gates) + WiredIn -> returnRn (decls, fvs, gates `plusFV` getWiredInGates wanted_name) + Deferred -> returnRn (decls, fvs, gates `addOneFV` wanted_name) -- It's a type constructor + + HereItIs decl -> rnIfaceDecl decl `thenRn` \ (new_decl, fvs1) -> + returnRn (new_decl : decls, + fvs1 `plusFV` fvs, + gates `plusFV` getGates source_fvs new_decl) rnInstDecls decls fvs gates [] = returnRn (decls, fvs, gates) @@ -379,17 +385,6 @@ closeDecls decls needed ------------------------------------------------------- -rnIfaceDecls :: [RenamedHsDecl] -> FreeVars - -> [(Module, RdrNameHsDecl)] - -> RnM d ([RenamedHsDecl], FreeVars) -rnIfaceDecls decls fvs [] = returnRn (decls, fvs) -rnIfaceDecls decls fvs (d:ds) = rnIfaceDecl d `thenRn` \ (new_decl, fvs1) -> - rnIfaceDecls (new_decl:decls) (fvs1 `plusFV` fvs) ds - -rnIfaceDecl (mod, decl) = initIfaceRnMS mod (rnDecl decl) - - -------------------------------------------------------- -- Augment decls with any decls needed by needed. -- Return also free vars of the new decls (only) slurpDecls decls needed @@ -401,14 +396,66 @@ slurpDecls decls needed ------------------------------------------------------- slurpDecl decls fvs wanted_name - = importDecl wanted_name `thenRn` \ maybe_decl -> - case maybe_decl of - -- No declaration... (wired in thing) - Nothing -> returnRn (decls, fvs) - + = importDecl wanted_name `thenRn` \ import_result -> + case import_result of -- Found a declaration... rename it - Just decl -> rnIfaceDecl decl `thenRn` \ (new_decl, fvs1) -> - returnRn (new_decl:decls, fvs1 `plusFV` fvs) + HereItIs decl -> rnIfaceDecl decl `thenRn` \ (new_decl, fvs1) -> + returnRn (new_decl:decls, fvs1 `plusFV` fvs) + + -- No declaration... (wired in thing, or deferred, or already slurped) + other -> returnRn (decls, fvs) + + +------------------------------------------------------- +rnIfaceDecls :: [RenamedHsDecl] -> FreeVars + -> [(Module, RdrNameHsDecl)] + -> RnM d ([RenamedHsDecl], FreeVars) +rnIfaceDecls decls fvs [] = returnRn (decls, fvs) +rnIfaceDecls decls fvs (d:ds) = rnIfaceDecl d `thenRn` \ (new_decl, fvs1) -> + rnIfaceDecls (new_decl:decls) (fvs1 `plusFV` fvs) ds + +rnIfaceDecl (mod, decl) = initIfaceRnMS mod (rnDecl decl) +\end{code} + + +%********************************************************* +%* * +\subsection{Deferred declarations} +%* * +%********************************************************* + +The idea of deferred declarations is this. Suppose we have a function + f :: T -> Int + data T = T1 A | T2 B + data A = A1 X | A2 Y + data B = B1 P | B2 Q +Then we don't want to load T and all its constructors, and all +the types those constructors refer to, and all the types *those* +constructors refer to, and so on. That might mean loading many more +interface files than is really necessary. So we 'defer' loading T. + +But f might be strict, and the calling convention for evaluating +values of type T depends on how many constructors T has, so +we do need to load T, but not the full details of the type T. +So we load the full decl for T, but only skeleton decls for A and B: + f :: T -> Int + data T = {- 2 constructors -} + +Whether all this is worth it is moot. + +\begin{code} +slurpDeferredDecls :: [RenamedHsDecl] -> RnMG [RenamedHsDecl] +slurpDeferredDecls decls + = getDeferredDecls `thenRn` \ def_decls -> + rnIfaceDecls decls emptyFVs (map stripDecl def_decls) `thenRn` \ (decls1, fvs) -> + ASSERT( isEmptyFVs fvs ) + returnRn decls1 + +stripDecl (mod, TyClD (TyData dt _ tc tvs _ nconstrs _ _ loc)) + = (mod, TyClD (TyData dt [] tc tvs [] nconstrs Nothing NoDataPragmas loc)) + -- Nuke the context and constructors + -- But retain the *number* of constructors! + -- Also the tvs will have kinds on them. \end{code} @@ -461,7 +508,7 @@ getGates source_fvs (TyClD (TySynonym tycon tvs ty _)) (map getTyVarName tvs) -- A type synonym type constructor isn't a "gate" for instance decls -getGates source_fvs (TyClD (TyData _ ctxt tycon tvs cons _ _ _)) +getGates source_fvs (TyClD (TyData _ ctxt tycon tvs cons _ _ _ _)) = delListFromNameSet (foldr (plusFV . get) (extractHsCtxtTyNames ctxt) cons) (map getTyVarName tvs) `addOneToNameSet` tycon @@ -525,6 +572,81 @@ getInstDeclGates other = emptyFVs %********************************************************* %* * +\subsection{Fixities} +%* * +%********************************************************* + +\begin{code} +fixitiesFromLocalDecls :: GlobalRdrEnv -> [RdrNameHsDecl] -> RnMG FixityEnv +fixitiesFromLocalDecls gbl_env decls + = foldlRn getFixities emptyNameEnv decls `thenRn` \ env -> + traceRn (text "fixity env" <+> vcat (map ppr (nameEnvElts env))) `thenRn_` + returnRn env + where + getFixities :: FixityEnv -> RdrNameHsDecl -> RnMG FixityEnv + getFixities acc (FixD fix) + = fix_decl acc fix + + getFixities acc (TyClD (ClassDecl _ _ _ _ sigs _ _ _ _ _ _ _)) + = foldlRn fix_decl acc [sig | FixSig sig <- sigs] + -- Get fixities from class decl sigs too. + getFixities acc other_decl + = returnRn acc + + fix_decl acc sig@(FixitySig rdr_name fixity loc) + = -- Check for fixity decl for something not declared + case lookupRdrEnv gbl_env rdr_name of { + Nothing | opt_WarnUnusedBinds + -> pushSrcLocRn loc (addWarnRn (unusedFixityDecl rdr_name fixity)) + `thenRn_` returnRn acc + | otherwise -> returnRn acc ; + + Just (name:_) -> + + -- Check for duplicate fixity decl + case lookupNameEnv acc name of { + Just (FixitySig _ _ loc') -> addErrRn (dupFixityDecl rdr_name loc loc') + `thenRn_` returnRn acc ; + + Nothing -> returnRn (addToNameEnv acc name (FixitySig name fixity loc)) + }} +\end{code} + + +%********************************************************* +%* * +\subsection{Deprecations} +%* * +%********************************************************* + +For deprecations, all we do is check that the names are in scope. +It's only imported deprecations, dealt with in RnIfaces, that we +gather them together. + +\begin{code} +rnDeprecs :: GlobalRdrEnv -> Maybe DeprecTxt + -> [RdrNameHsDecl] -> RnMG [RdrNameDeprecation] +rnDeprecs gbl_env mod_deprec decls + = mapRn rn_deprec deprecs `thenRn_` + returnRn (extra_deprec ++ deprecs) + where + deprecs = [d | DeprecD d <- decls] + extra_deprec = case mod_deprec of + Nothing -> [] + Just txt -> [Deprecation (IEModuleContents undefined) txt noSrcLoc] + + rn_deprec (Deprecation ie txt loc) + = pushSrcLocRn loc $ + mapRn check (ieNames ie) + + check n = case lookupRdrEnv gbl_env n of + Nothing -> addErrRn (unknownNameErr n) + Just _ -> returnRn () +\end{code} + + +%********************************************************* +%* * \subsection{Unused names} %* * %********************************************************* @@ -532,10 +654,10 @@ getInstDeclGates other = emptyFVs \begin{code} reportUnusedNames :: ModuleName -> [ModuleName] -> GlobalRdrEnv -> AvailEnv - -> ExportEnv -> NameSet -> RnMG () + -> Avails -> NameSet -> RnMG () reportUnusedNames mod_name direct_import_mods gbl_env avail_env - (ExportEnv export_avails _ _) mentioned_names + export_avails mentioned_names = let used_names = mentioned_names `unionNameSets` availsToNameSet export_avails @@ -647,25 +769,18 @@ printMinimalImports mod_name imps other -> pprTrace "to_ie" (ppr n <+> ppr (nameModule n) <+> ppr other) $ returnRn (IEVar n) -warnDeprec :: (Name, DeprecTxt) -> RnM d () -warnDeprec (name, txt) - = pushSrcLocRn (getSrcLoc name) $ - addWarnRn $ - sep [ text (occNameFlavour (nameOccName name)) <+> ppr name <+> - text "is deprecated:", nest 4 (ppr txt) ] - - rnDump :: [RenamedHsDecl] -- Renamed imported decls -> [RenamedHsDecl] -- Renamed local decls -> RnMG (IO ()) -rnDump imp_decls decls +rnDump imp_decls local_decls | opt_D_dump_rn_trace || opt_D_dump_rn_stats || opt_D_dump_rn = getRnStats imp_decls `thenRn` \ stats_msg -> returnRn (printErrs stats_msg >> - dumpIfSet opt_D_dump_rn "Renamer:" (vcat (map ppr decls))) + dumpIfSet opt_D_dump_rn "Renamer:" + (vcat (map ppr (local_decls ++ imp_decls)))) | otherwise = returnRn (return ()) \end{code} @@ -682,7 +797,7 @@ getRnStats :: [RenamedHsDecl] -> RnMG SDoc getRnStats imported_decls = getIfacesRn `thenRn` \ ifaces -> let - n_mods = length [() | (_, _, _, Just _) <- eltsFM (iImpModInfo ifaces)] + n_mods = length [() | (_, _, Just _) <- eltsFM (iImpModInfo ifaces)] decls_read = [decl | (_, avail, True, (_,decl)) <- nameEnvElts (iDecls ifaces), -- Data, newtype, and class decls are in the decls_fm @@ -735,3 +850,27 @@ count_decls decls inst_decls = length [() | InstD _ <- decls] \end{code} + +%************************************************************************ +%* * +\subsection{Errors and warnings} +%* * +%************************************************************************ + +\begin{code} +warnDeprec :: (Name, DeprecTxt) -> RnM d () +warnDeprec (name, txt) + = pushSrcLocRn (getSrcLoc name) $ + addWarnRn $ + sep [ text (occNameFlavour (nameOccName name)) <+> ppr name <+> + text "is deprecated:", nest 4 (ppr txt) ] + + +unusedFixityDecl rdr_name fixity + = hsep [ptext SLIT("Unused fixity declaration for"), quotes (ppr rdr_name)] + +dupFixityDecl rdr_name loc1 loc2 + = vcat [ptext SLIT("Multiple fixity declarations for") <+> quotes (ppr rdr_name), + ptext SLIT("at ") <+> ppr loc1, + ptext SLIT("and") <+> ppr loc2] +\end{code} diff --git a/ghc/compiler/rename/RnBinds.lhs b/ghc/compiler/rename/RnBinds.lhs index ff10456d0e..17284cedc3 100644 --- a/ghc/compiler/rename/RnBinds.lhs +++ b/ghc/compiler/rename/RnBinds.lhs @@ -21,12 +21,13 @@ module RnBinds ( import {-# SOURCE #-} RnSource ( rnHsSigType ) import HsSyn -import HsBinds ( sigsForMe, cmpHsSig, sigName, hsSigDoc ) +import HsBinds ( eqHsSig, sigName, hsSigDoc ) import RdrHsSyn import RnHsSyn import RnMonad import RnExpr ( rnMatch, rnGRHSs, rnPat, checkPrecMatch ) -import RnEnv ( bindLocatedLocalsRn, lookupBndrRn, lookupGlobalOccRn, lookupOccRn, +import RnEnv ( bindLocatedLocalsRn, lookupBndrRn, + lookupGlobalOccRn, lookupOccRn, lookupSigOccRn, warnUnusedLocalBinds, mapFvRn, FreeVars, emptyFVs, plusFV, plusFVs, unitFV, addOneFV, unknownNameErr @@ -172,11 +173,14 @@ rnTopMonoBinds EmptyMonoBinds sigs = returnRn (EmptyBinds, emptyFVs) rnTopMonoBinds mbinds sigs - = mapRn lookupBndrRn binder_rdr_names `thenRn` \ binder_names -> - renameSigs (okBindSig (mkNameSet binder_names)) sigs `thenRn` \ (siglist, sig_fvs) -> + = mapRn lookupBndrRn binder_rdr_names `thenRn` \ binder_names -> + let + bndr_name_set = mkNameSet binder_names + in + renameSigs (okBindSig bndr_name_set) sigs `thenRn` \ (siglist, sig_fvs) -> let type_sig_vars = [n | Sig n _ _ <- siglist] - un_sigd_binders | opt_WarnMissingSigs = binder_names `minusList` type_sig_vars + un_sigd_binders | opt_WarnMissingSigs = nameSetToList (delListFromNameSet bndr_name_set type_sig_vars) | otherwise = [] in mapRn_ (addWarnRn.missingSigWarn) un_sigd_binders `thenRn_` @@ -317,8 +321,8 @@ flattenMonoBinds sigs (PatMonoBind pat grhss locn) -- Find which things are bound in this group let names_bound_here = mkNameSet (collectPatBinders pat') - sigs_for_me = sigsForMe (`elemNameSet` names_bound_here) sigs in + sigsForMe names_bound_here sigs `thenRn` \ sigs_for_me -> rnGRHSs grhss `thenRn` \ (grhss', fvs) -> returnRn [(names_bound_here, @@ -331,8 +335,9 @@ flattenMonoBinds sigs (FunMonoBind name inf matches locn) = pushSrcLocRn locn $ lookupBndrRn name `thenRn` \ new_name -> let - sigs_for_me = sigsForMe (new_name ==) sigs + names_bound_here = unitNameSet new_name in + sigsForMe names_bound_here sigs `thenRn` \ sigs_for_me -> mapFvRn rnMatch matches `thenRn` \ (new_matches, fvs) -> mapRn_ (checkPrecMatch inf new_name) new_matches `thenRn_` returnRn @@ -341,6 +346,15 @@ flattenMonoBinds sigs (FunMonoBind name inf matches locn) FunMonoBind new_name inf new_matches locn, sigs_for_me )] + + +sigsForMe names_bound_here sigs + = foldlRn check [] (filter (sigForThisGroup names_bound_here) sigs) + where + check sigs sig = case filter (eqHsSig sig) sigs of + [] -> returnRn (sig:sigs) + other -> dupSigDeclErr sig `thenRn_` + returnRn sigs \end{code} @@ -477,14 +491,12 @@ renameSigs ok_sig sigs is_in_scope sig = case sigName sig of Just n -> not (isUnboundName n) Nothing -> True - (not_dups, dups) = removeDups cmpHsSig in_scope - (goods, bads) = partition ok_sig not_dups + (goods, bads) = partition ok_sig in_scope in mapRn_ unknownSigErr bads `thenRn_` - mapRn_ dupSigDeclErr dups `thenRn_` returnRn (goods, fvs) --- We use lookupOccRn in the signatures, which is a little bit unsatisfactory +-- We use lookupSigOccRn in the signatures, which is a little bit unsatisfactory -- because this won't work for: -- instance Foo T where -- {-# INLINE op #-} @@ -497,7 +509,7 @@ renameSig :: Sig RdrName -> RnMS (Sig Name, FreeVars) renameSig (Sig v ty src_loc) = pushSrcLocRn src_loc $ - lookupOccRn v `thenRn` \ new_v -> + lookupSigOccRn v `thenRn` \ new_v -> rnHsSigType (quotes (ppr v)) ty `thenRn` \ (new_ty,fvs) -> returnRn (Sig new_v new_ty src_loc, fvs `addOneFV` new_v) @@ -508,28 +520,23 @@ renameSig (SpecInstSig ty src_loc) renameSig (SpecSig v ty src_loc) = pushSrcLocRn src_loc $ - lookupOccRn v `thenRn` \ new_v -> + lookupSigOccRn v `thenRn` \ new_v -> rnHsSigType (quotes (ppr v)) ty `thenRn` \ (new_ty,fvs) -> returnRn (SpecSig new_v new_ty src_loc, fvs `addOneFV` new_v) renameSig (FixSig (FixitySig v fix src_loc)) = pushSrcLocRn src_loc $ - lookupOccRn v `thenRn` \ new_v -> + lookupSigOccRn v `thenRn` \ new_v -> returnRn (FixSig (FixitySig new_v fix src_loc), unitFV new_v) -renameSig (DeprecSig (Deprecation ie txt) src_loc) - = pushSrcLocRn src_loc $ - renameIE lookupOccRn ie `thenRn` \ (new_ie, fvs) -> - returnRn (DeprecSig (Deprecation new_ie txt) src_loc, fvs) - renameSig (InlineSig v p src_loc) = pushSrcLocRn src_loc $ - lookupOccRn v `thenRn` \ new_v -> + lookupSigOccRn v `thenRn` \ new_v -> returnRn (InlineSig new_v p src_loc, unitFV new_v) renameSig (NoInlineSig v p src_loc) = pushSrcLocRn src_loc $ - lookupOccRn v `thenRn` \ new_v -> + lookupSigOccRn v `thenRn` \ new_v -> returnRn (NoInlineSig new_v p src_loc, unitFV new_v) \end{code} @@ -564,7 +571,7 @@ renameIE lookup_occ_nm (IEModuleContents m) %************************************************************************ \begin{code} -dupSigDeclErr (sig:sigs) +dupSigDeclErr sig = pushSrcLocRn loc $ addErrRn (sep [ptext SLIT("Duplicate") <+> ptext what_it_is <> colon, ppr sig]) diff --git a/ghc/compiler/rename/RnEnv.lhs b/ghc/compiler/rename/RnEnv.lhs index 25e895fc63..05ec12accc 100644 --- a/ghc/compiler/rename/RnEnv.lhs +++ b/ghc/compiler/rename/RnEnv.lhs @@ -22,10 +22,9 @@ import RnMonad import Name ( Name, Provenance(..), ExportFlag(..), NamedThing(..), ImportReason(..), getSrcLoc, mkLocalName, mkImportedLocalName, mkGlobalName, mkUnboundName, - mkIPName, isSystemName, isWiredInName, + mkIPName, isWiredInName, hasBetterProv, nameOccName, setNameModule, nameModule, pprOccName, isLocallyDefined, nameUnique, nameOccName, - occNameUserString, setNameProvenance, getNameProvenance, pprNameProvenance ) import NameSet @@ -33,7 +32,7 @@ import OccName ( OccName, mkDFunOcc, occNameUserString, occNameString, occNameFlavour ) -import TysWiredIn ( tupleTyCon, unboxedTupleTyCon, listTyCon ) +import TysWiredIn ( listTyCon ) import Type ( funTyCon ) import Module ( ModuleName, mkThisModule, moduleName, mkVanillaModule, pprModuleName ) import TyCon ( TyCon ) @@ -42,7 +41,7 @@ import Unique ( Unique, Uniquable(..) ) import UniqSupply import SrcLoc ( SrcLoc, noSrcLoc ) import Outputable -import Util ( removeDups, equivClasses, thenCmp ) +import Util ( removeDups, equivClasses, thenCmp, sortLt ) import List ( nub ) \end{code} @@ -55,63 +54,58 @@ import List ( nub ) %********************************************************* \begin{code} -newLocalTopBinder :: Module -> OccName - -> (Name -> ExportFlag) -> SrcLoc - -> RnM d Name -newLocalTopBinder mod occ rec_exp_fn loc - = newTopBinder mod occ (\name -> setNameProvenance name (LocalDef loc (rec_exp_fn name))) - -- We must set the provenance of the thing in the cache - -- correctly, particularly whether or not it is locally defined. - -- - -- Since newLocalTopBinder is used only - -- at binding occurrences, we may as well get the provenance - -- dead right first time; hence the rec_exp_fn passed in - -newImportedBinder :: Module -> RdrName -> RnM d Name -newImportedBinder mod rdr_name - = ASSERT2( isUnqual rdr_name, ppr rdr_name ) - newTopBinder mod (rdrNameOcc rdr_name) (\name -> name) - -- Provenance is already implicitImportProvenance - implicitImportProvenance = NonLocalDef ImplicitImport False -newTopBinder :: Module -> OccName -> (Name -> Name) -> RnM d Name -newTopBinder mod occ set_prov +newTopBinder :: Module -> OccName -> RnM d Name +newTopBinder mod occ = -- First check the cache + traceRn (text "newTopBinder" <+> ppr mod <+> ppr occ) `thenRn_` + getNameSupplyRn `thenRn` \ (us, inst_ns, cache, ipcache) -> let key = (moduleName mod, occ) in case lookupFM cache key of - -- A hit in the cache! - -- Set the Module of the thing, and set its provenance (hack pending - -- spj update) + -- A hit in the cache! We are at the binding site of the name, which is + -- the time we know all about the Name's host Module (in particular, which + -- package it comes from), so update the Module in the name. + -- But otherwise *leave the Provenance alone*: -- - -- It also means that if there are two defns for the same thing - -- in a module, then each gets a separate SrcLoc + -- * For imported names, the Provenance may already be correct. + -- e.g. We imported Prelude.hi, and set the provenance of PrelShow.Show + -- to 'UserImport from Prelude'. Note that we havn't yet opened PrelShow.hi + -- Later we find we really need PrelShow.Show, so we open PrelShow.hi, and + -- that's when we find the binding occurrence of Show. -- - -- There's a complication for wired-in names. We don't want to + -- * For locally defined names, we do a setProvenance on the Name + -- right after newTopBinder, and then use updateProveances to finally + -- set the provenances in the cache correctly. + -- + -- NB: for wired-in names it's important not to -- forget that they are wired in even when compiling that module -- (else we spit out redundant defns into the interface file) - -- So for them we just set the provenance Just name -> let - new_name = set_prov (setNameModule name mod) + new_name = setNameModule name mod new_cache = addToFM cache key new_name in setNameSupplyRn (us, inst_ns, new_cache, ipcache) `thenRn_` + traceRn (text "newTopBinder: overwrite" <+> ppr new_name) `thenRn_` returnRn new_name -- Miss in the cache! -- Build a completely new Name, and put it in the cache + -- Even for locally-defined names we use implicitImportProvenance; + -- updateProvenances will set it to rights Nothing -> let (us', us1) = splitUniqSupply us uniq = uniqFromSupply us1 - new_name = set_prov (mkGlobalName uniq mod occ implicitImportProvenance) + new_name = mkGlobalName uniq mod occ implicitImportProvenance new_cache = addToFM cache key new_name in setNameSupplyRn (us', inst_ns, new_cache, ipcache) `thenRn_` + traceRn (text "newTopBinder: new" <+> ppr new_name) `thenRn_` returnRn new_name @@ -136,8 +130,10 @@ mkImportedGlobalName mod_name occ key = (mod_name, occ) in case lookupFM cache key of - Just name -> returnRn name - Nothing -> setNameSupplyRn (us', inst_ns, new_cache, ipcache) `thenRn_` + Just name -> traceRn (text "mkImportedGlobalName: hit" <+> ppr name) `thenRn_` + returnRn name + Nothing -> setNameSupplyRn (us', inst_ns, new_cache, ipcache) `thenRn_` + traceRn (text "mkImportedGlobalName: new" <+> ppr name) `thenRn_` returnRn name where (us', us1) = splitUniqSupply us @@ -175,7 +171,6 @@ updateProvenances names = setNameProvenance name_in_cache (getNameProvenance name_with_prov) - mkImportedGlobalFromRdrName :: RdrName -> RnM d Name mkImportedGlobalFromRdrName rdr_name | isQual rdr_name @@ -209,13 +204,16 @@ getIPName rdr_name %* * %********************************************************* -@newImplicitBinder@ is used for (a) dfuns -(b) default methods, defined in this module. +@newImplicitBinder@ is used for + (a) dfuns (RnSource.rnDecl on InstDecls) + (b) default methods (RnSource.rnDecl on ClassDecls) +when these dfuns/default methods are defined in the module being compiled \begin{code} newImplicitBinder occ src_loc = getModuleRn `thenRn` \ mod_name -> - newLocalTopBinder (mkThisModule mod_name) occ (\_ -> Exported) src_loc + newTopBinder (mkThisModule mod_name) occ `thenRn` \ name -> + returnRn (setNameProvenance name (LocalDef src_loc Exported)) \end{code} Make a name for the dict fun for an instance decl @@ -232,16 +230,15 @@ newDFunName key@(cl_occ, tycon_occ) loc \begin{code} getDFunKey :: RenamedHsType -> (OccName, OccName) -- Used to manufacture DFun names -getDFunKey (HsForAllTy _ _ ty) = getDFunKey ty -getDFunKey (MonoFunTy _ ty) = getDFunKey ty -getDFunKey (MonoDictTy cls (ty:_)) = (nameOccName cls, get_tycon_key ty) - -get_tycon_key (MonoTyVar tv) = nameOccName (getName tv) -get_tycon_key (MonoTyApp ty _) = get_tycon_key ty -get_tycon_key (MonoTupleTy tys True) = getOccName (tupleTyCon (length tys)) -get_tycon_key (MonoTupleTy tys False) = getOccName (unboxedTupleTyCon (length tys)) -get_tycon_key (MonoListTy _) = getOccName listTyCon -get_tycon_key (MonoFunTy _ _) = getOccName funTyCon +getDFunKey (HsForAllTy _ _ ty) = getDFunKey ty +getDFunKey (HsFunTy _ ty) = getDFunKey ty +getDFunKey (HsPredTy (HsPClass cls (ty:_))) = (nameOccName cls, get_tycon_key ty) + +get_tycon_key (HsTyVar tv) = getOccName tv +get_tycon_key (HsAppTy ty _) = get_tycon_key ty +get_tycon_key (HsTupleTy (HsTupCon n _) tys) = getOccName n +get_tycon_key (HsListTy _) = getOccName listTyCon +get_tycon_key (HsFunTy _ _) = getOccName funTyCon \end{code} @@ -351,7 +348,7 @@ bindUVarRn :: SDoc -> RdrName -> (Name -> RnMS (a, FreeVars)) -> RnMS (a, FreeVa bindUVarRn = bindLocalRn ------------------------------------- -extendTyVarEnvFVRn :: [HsTyVar Name] -> RnMS (a, FreeVars) -> RnMS (a, FreeVars) +extendTyVarEnvFVRn :: [HsTyVarBndr Name] -> RnMS (a, FreeVars) -> RnMS (a, FreeVars) -- This tiresome function is used only in rnDecl on InstDecl extendTyVarEnvFVRn tyvars enclosed_scope = getLocalNameEnv `thenRn` \ env -> @@ -364,16 +361,16 @@ extendTyVarEnvFVRn tyvars enclosed_scope setLocalNameEnv new_env enclosed_scope `thenRn` \ (thing, fvs) -> returnRn (thing, delListFromNameSet fvs tyvar_names) -bindTyVarsRn :: SDoc -> [HsTyVar RdrName] - -> ([HsTyVar Name] -> RnMS a) +bindTyVarsRn :: SDoc -> [HsTyVarBndr RdrName] + -> ([HsTyVarBndr Name] -> RnMS a) -> RnMS a bindTyVarsRn doc_str tyvar_names enclosed_scope = bindTyVars2Rn doc_str tyvar_names $ \ names tyvars -> enclosed_scope tyvars -- Gruesome name: return Names as well as HsTyVars -bindTyVars2Rn :: SDoc -> [HsTyVar RdrName] - -> ([Name] -> [HsTyVar Name] -> RnMS a) +bindTyVars2Rn :: SDoc -> [HsTyVarBndr RdrName] + -> ([Name] -> [HsTyVarBndr Name] -> RnMS a) -> RnMS a bindTyVars2Rn doc_str tyvar_names enclosed_scope = getSrcLocRn `thenRn` \ loc -> @@ -383,16 +380,16 @@ bindTyVars2Rn doc_str tyvar_names enclosed_scope bindLocatedLocalsRn doc_str located_tyvars $ \ names -> enclosed_scope names (zipWith replaceTyVarName tyvar_names names) -bindTyVarsFVRn :: SDoc -> [HsTyVar RdrName] - -> ([HsTyVar Name] -> RnMS (a, FreeVars)) +bindTyVarsFVRn :: SDoc -> [HsTyVarBndr RdrName] + -> ([HsTyVarBndr Name] -> RnMS (a, FreeVars)) -> RnMS (a, FreeVars) bindTyVarsFVRn doc_str rdr_names enclosed_scope = bindTyVars2Rn doc_str rdr_names $ \ names tyvars -> enclosed_scope tyvars `thenRn` \ (thing, fvs) -> returnRn (thing, delListFromNameSet fvs names) -bindTyVarsFV2Rn :: SDoc -> [HsTyVar RdrName] - -> ([Name] -> [HsTyVar Name] -> RnMS (a, FreeVars)) +bindTyVarsFV2Rn :: SDoc -> [HsTyVarBndr RdrName] + -> ([Name] -> [HsTyVarBndr Name] -> RnMS (a, FreeVars)) -> RnMS (a, FreeVars) bindTyVarsFV2Rn doc_str rdr_names enclosed_scope = bindTyVars2Rn doc_str rdr_names $ \ names tyvars -> @@ -431,7 +428,8 @@ Looking up a name in the RnEnv. \begin{code} lookupBndrRn rdr_name - = getNameEnvs `thenRn` \ (global_env, local_env) -> + = traceRn (text "lookupBndrRn" <+> ppr rdr_name) `thenRn_` + getNameEnvs `thenRn` \ (global_env, local_env) -> -- Try local env case lookupRdrEnv local_env rdr_name of { @@ -441,7 +439,9 @@ lookupBndrRn rdr_name getModeRn `thenRn` \ mode -> case mode of InterfaceMode -> -- Look in the global name cache - mkImportedGlobalFromRdrName rdr_name + mkImportedGlobalFromRdrName rdr_name `thenRn` \ n -> + traceRn (text "lookupBndrRn result:" <+> ppr n) `thenRn_` + returnRn n SourceMode -> -- Source mode, so look up a *qualified* version -- of the name, so that we get the right one even @@ -454,10 +454,7 @@ lookupBndrRn rdr_name Nothing -> pprPanic "lookupBndrRn" (ppr mod <+> ppr rdr_name) } --- Just like lookupRn except that we record the occurrence too --- Perhaps surprisingly, even wired-in names are recorded. --- Why? So that we know which wired-in names are referred to when --- deciding which instance declarations to import. +-- lookupOccRn looks up an occurrence of a RdrName lookupOccRn :: RdrName -> RnMS Name lookupOccRn rdr_name = getNameEnvs `thenRn` \ (global_env, local_env) -> @@ -472,6 +469,45 @@ lookupGlobalOccRn rdr_name = getNameEnvs `thenRn` \ (global_env, local_env) -> lookup_global_occ global_env rdr_name +-- lookupSigOccRn is used for type signatures and pragmas +-- Is this valid? +-- module A +-- import M( f ) +-- f :: Int -> Int +-- f x = x +-- In a sense, it's clear that the 'f' in the signature must refer +-- to A.f, but the Haskell98 report does not stipulate this, so +-- I treat the 'f' in the signature as a reference to an unqualified +-- 'f' and hence fail with an ambiguous reference. +lookupSigOccRn :: RdrName -> RnMS Name +lookupSigOccRn = lookupOccRn + +{- OLD VERSION +-- This code tries to be cleverer than the above. +-- The variable in a signature must refer to a locally-defined thing, +-- even if there's an imported thing of the same name. +-- +-- But this doesn't work for instance decls: +-- instance Enum Int where +-- {-# INLINE enumFrom #-} +-- ... +-- Here the enumFrom is an imported reference! +lookupSigOccRn rdr_name + = getNameEnvs `thenRn` \ (global_env, local_env) -> + case (lookupRdrEnv local_env rdr_name, lookupRdrEnv global_env rdr_name) of + (Just name, _) -> returnRn name + + (Nothing, Just names) -> case filter isLocallyDefined names of + [n] -> returnRn n + ns -> pprPanic "lookupSigOccRn" (ppr rdr_name <+> ppr names <+> ppr ns) + -- There can't be a local top-level name-clash + -- (That's dealt with elsewhere.) + + (Nothing, Nothing) -> failWithRn (mkUnboundName rdr_name) + (unknownNameErr rdr_name) +-} + + -- Look in both local and global env lookup_occ global_env local_env rdr_name = case lookupRdrEnv local_env rdr_name of @@ -517,6 +553,11 @@ The name cache should have the correct provenance, though. \begin{code} lookupImplicitOccRn :: RdrName -> RnM d Name lookupImplicitOccRn rdr_name = mkImportedGlobalFromRdrName rdr_name + +lookupImplicitOccsRn :: [RdrName] -> RnM d NameSet +lookupImplicitOccsRn rdr_names + = mapRn lookupImplicitOccRn rdr_names `thenRn` \ names -> + returnRn (mkNameSet names) \end{code} @unQualInScope@ returns a function that takes a @Name@ and tells whether @@ -561,19 +602,9 @@ combine_globals ns_old ns_new -- ns_new is often short add n ns | any (is_duplicate n) ns_old = map choose ns -- Eliminate duplicates | otherwise = n:ns where - choose n' | n==n' && better_provenance n n' = n - | otherwise = n' - --- 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 -better_provenance n1 n2 - = case (getNameProvenance n1, getNameProvenance n2) of - (LocalDef _ _, _ ) -> True - (NonLocalDef (UserImport _ _ True) _, _ ) -> True - (NonLocalDef (UserImport _ _ _ ) _, NonLocalDef ImplicitImport _) -> True - other -> False + choose m | n==m && n `hasBetterProv` m = n + | otherwise = m + is_duplicate :: Name -> Name -> Bool is_duplicate n1 n2 | isLocallyDefined n1 && isLocallyDefined n2 = False @@ -621,11 +652,11 @@ addAvailToNameSet names avail = addListToNameSet names (availNames avail) availsToNameSet :: [AvailInfo] -> NameSet availsToNameSet avails = foldl addAvailToNameSet emptyNameSet avails -availName :: AvailInfo -> Name +availName :: GenAvailInfo name -> name availName (Avail n) = n availName (AvailTC n _) = n -availNames :: AvailInfo -> [Name] +availNames :: GenAvailInfo name -> [name] availNames (Avail n) = [n] availNames (AvailTC n ns) = ns @@ -633,6 +664,12 @@ addSysAvails :: AvailInfo -> [Name] -> AvailInfo addSysAvails avail [] = avail addSysAvails (AvailTC n ns) sys = AvailTC n (sys ++ ns) +rdrAvailInfo :: AvailInfo -> RdrAvailInfo +-- Used when building the avails we are going to put in an interface file +-- We sort the components to reduce needless wobbling of interfaces +rdrAvailInfo (Avail n) = Avail (nameOccName n) +rdrAvailInfo (AvailTC n ns) = AvailTC (nameOccName n) (sortLt (<) (map nameOccName ns)) + filterAvail :: RdrNameIE -- Wanted -> AvailInfo -- Available -> Maybe AvailInfo -- Resulting available; diff --git a/ghc/compiler/rename/RnExpr.lhs b/ghc/compiler/rename/RnExpr.lhs index 8669ca64e6..7bfa409821 100644 --- a/ghc/compiler/rename/RnExpr.lhs +++ b/ghc/compiler/rename/RnExpr.lhs @@ -18,21 +18,22 @@ module RnExpr ( #include "HsVersions.h" import {-# SOURCE #-} RnBinds ( rnBinds ) -import {-# SOURCE #-} RnSource ( rnHsSigType, rnHsPolyType, rnHsType ) +import {-# SOURCE #-} RnSource ( rnHsSigType, rnHsType ) import HsSyn import RdrHsSyn import RnHsSyn import RnMonad import RnEnv -import RnIfaces ( lookupFixity ) +import RnIfaces ( lookupFixityRn ) import CmdLineOpts ( opt_GlasgowExts, opt_IgnoreAsserts ) import BasicTypes ( Fixity(..), FixityDirection(..), defaultFixity, negateFixity, negatePrecedence ) import PrelInfo ( numClass_RDR, fractionalClass_RDR, eqClass_RDR, ccallableClass_RDR, creturnableClass_RDR, monadClass_RDR, enumClass_RDR, ordClass_RDR, ratioDataCon_RDR, negate_RDR, assertErr_RDR, - ioDataCon_RDR + ioDataCon_RDR, addr2Integer_RDR, + foldr_RDR, build_RDR ) import TysPrim ( charPrimTyCon, addrPrimTyCon, intPrimTyCon, floatPrimTyCon, doublePrimTyCon @@ -44,7 +45,7 @@ import NameSet import UniqFM ( isNullUFM ) import FiniteMap ( elemFM ) import UniqSet ( emptyUniqSet, UniqSet ) -import Unique ( assertIdKey ) +import Unique ( hasKey, assertIdKey ) import Util ( removeDups ) import ListSetOps ( unionLists ) import Maybes ( maybeToBool ) @@ -70,7 +71,7 @@ rnPat (VarPatIn name) rnPat (SigPatIn pat ty) | opt_GlasgowExts = rnPat pat `thenRn` \ (pat', fvs1) -> - rnHsPolyType doc ty `thenRn` \ (ty', fvs2) -> + rnHsType doc ty `thenRn` \ (ty', fvs2) -> returnRn (SigPatIn pat' ty', fvs1 `plusFV` fvs2) | otherwise @@ -107,7 +108,7 @@ rnPat (ConOpPatIn pat1 con _ pat2) -- See comments with rnExpr (OpApp ...) (case mode of InterfaceMode -> returnRn (ConOpPatIn pat1' con' defaultFixity pat2') - SourceMode -> lookupFixity con' `thenRn` \ fixity -> + SourceMode -> lookupFixityRn con' `thenRn` \ fixity -> mkConOpPatRn pat1' con' fixity pat2' ) `thenRn` \ pat' -> returnRn (pat', fvs1 `plusFV` fvs2 `addOneFV` con') @@ -191,7 +192,7 @@ rnMatch match@(Match _ pats maybe_rhs_sig grhss) rnGRHSs grhss `thenRn` \ (grhss', grhss_fvs) -> (case maybe_rhs_sig of Nothing -> returnRn (Nothing, emptyFVs) - Just ty | opt_GlasgowExts -> rnHsPolyType doc_sig ty `thenRn` \ (ty', ty_fvs) -> + Just ty | opt_GlasgowExts -> rnHsType doc_sig ty `thenRn` \ (ty', ty_fvs) -> returnRn (Just ty', ty_fvs) | otherwise -> addErrRn (patSigErr ty) `thenRn_` returnRn (Nothing, emptyFVs) @@ -276,7 +277,7 @@ rnExpr :: RdrNameHsExpr -> RnMS (RenamedHsExpr, FreeVars) rnExpr (HsVar v) = lookupOccRn v `thenRn` \ name -> - if nameUnique name == assertIdKey then + if name `hasKey` assertIdKey then -- We expand it to (GHCerr.assert__ location) mkAssertExpr else @@ -312,7 +313,7 @@ rnExpr (OpApp e1 op _ e2) -- Don't even look up the fixity when in interface mode getModeRn `thenRn` \ mode -> (case mode of - SourceMode -> lookupFixity op_name `thenRn` \ fixity -> + SourceMode -> lookupFixityRn op_name `thenRn` \ fixity -> mkOpAppRn e1' op' fixity e2' InterfaceMode -> returnRn (OpApp e1' op' defaultFixity e2') ) `thenRn` \ final_e -> @@ -350,12 +351,12 @@ rnExpr section@(SectionR op expr) rnExpr (HsCCall fun args may_gc is_casm fake_result_ty) -- Check out the comment on RnIfaces.getNonWiredDataDecl about ccalls - = lookupImplicitOccRn ccallableClass_RDR `thenRn` \ cc -> - lookupImplicitOccRn creturnableClass_RDR `thenRn` \ cr -> - lookupImplicitOccRn ioDataCon_RDR `thenRn` \ io -> + = lookupImplicitOccsRn [ccallableClass_RDR, + creturnableClass_RDR, + ioDataCon_RDR] `thenRn` \ implicit_fvs -> rnExprs args `thenRn` \ (args', fvs_args) -> returnRn (HsCCall fun args' may_gc is_casm fake_result_ty, - fvs_args `addOneFV` cc `addOneFV` cr `addOneFV` io) + fvs_args `plusFV` implicit_fvs) rnExpr (HsSCC lbl expr) = rnExpr expr `thenRn` \ (expr', fvs_expr) -> @@ -379,7 +380,7 @@ rnExpr (HsWith expr binds) rnExpr e@(HsDo do_or_lc stmts src_loc) = pushSrcLocRn src_loc $ - lookupImplicitOccRn monadClass_RDR `thenRn` \ monad -> + lookupImplicitOccsRn implicit_rdr_names `thenRn` \ implicit_fvs -> rnStmts rnExpr stmts `thenRn` \ (stmts', fvs) -> -- check the statement list ends in an expression case last stmts' of { @@ -387,17 +388,23 @@ rnExpr e@(HsDo do_or_lc stmts src_loc) ReturnStmt _ -> returnRn () ; -- for list comprehensions _ -> addErrRn (doStmtListErr e) } `thenRn_` - returnRn (HsDo do_or_lc stmts' src_loc, fvs `addOneFV` monad) + returnRn (HsDo do_or_lc stmts' src_loc, fvs `plusFV` implicit_fvs) + where + implicit_rdr_names = [foldr_RDR, build_RDR, monadClass_RDR] + -- Monad stuff should not be necessary for a list comprehension + -- but the typechecker looks up the bind and return Ids anyway + -- Oh well. + rnExpr (ExplicitList exps) = rnExprs exps `thenRn` \ (exps', fvs) -> returnRn (ExplicitList exps', fvs `addOneFV` listTyCon_name) -rnExpr (ExplicitTuple exps boxed) +rnExpr (ExplicitTuple exps boxity) = rnExprs exps `thenRn` \ (exps', fvs) -> - returnRn (ExplicitTuple exps' boxed, fvs `addOneFV` tycon_name) + returnRn (ExplicitTuple exps' boxity, fvs `addOneFV` tycon_name) where - tycon_name = tupleTyCon_name boxed (length exps) + tycon_name = tupleTyCon_name boxity (length exps) rnExpr (RecordCon con_id rbinds) = lookupOccRn con_id `thenRn` \ conname -> @@ -722,8 +729,8 @@ checkPrecMatch True op (Match _ (p1:p2:_) _ _) checkPrecMatch True op _ = panic "checkPrecMatch" checkPrec op (ConOpPatIn _ op1 _ _) right - = lookupFixity op `thenRn` \ op_fix@(Fixity op_prec op_dir) -> - lookupFixity op1 `thenRn` \ op1_fix@(Fixity op1_prec op1_dir) -> + = lookupFixityRn op `thenRn` \ op_fix@(Fixity op_prec op_dir) -> + lookupFixityRn op1 `thenRn` \ op1_fix@(Fixity op1_prec op1_dir) -> let inf_ok = op1_prec > op_prec || (op1_prec == op_prec && @@ -737,7 +744,7 @@ checkPrec op (ConOpPatIn _ op1 _ _) right checkRn inf_ok (precParseErr infol infor) checkPrec op (NegPatIn _) right - = lookupFixity op `thenRn` \ op_fix@(Fixity op_prec op_dir) -> + = lookupFixityRn op `thenRn` \ op_fix@(Fixity op_prec op_dir) -> checkRn (op_prec <= negatePrecedence) (precParseNegPatErr (ppr_op op,op_fix)) checkPrec op pat right @@ -754,7 +761,7 @@ checkSectionPrec left_or_right section op arg where HsVar op_name = op go_for_it pp_arg_op arg_fix@(Fixity arg_prec _) - = lookupFixity op_name `thenRn` \ op_fix@(Fixity op_prec _) -> + = lookupFixityRn op_name `thenRn` \ op_fix@(Fixity op_prec _) -> checkRn (op_prec < arg_prec) (sectionPrecErr (ppr_op op_name, op_fix) (pp_arg_op, arg_fix) section) \end{code} @@ -808,13 +815,11 @@ litOccurrence (HsStringPrim _) = returnRn (unitFV (getName addrPrimTyCon)) litOccurrence (HsInt _) - = lookupImplicitOccRn numClass_RDR `thenRn` \ num -> - returnRn (unitFV num) -- Int and Integer are forced in by Num + = lookupImplicitOccsRn [numClass_RDR, addr2Integer_RDR] + -- Int and Integer are forced in by Num litOccurrence (HsFrac _) - = lookupImplicitOccRn fractionalClass_RDR `thenRn` \ frac -> - lookupImplicitOccRn ratioDataCon_RDR `thenRn` \ ratio -> - returnRn (unitFV frac `plusFV` unitFV ratio) + = lookupImplicitOccsRn [fractionalClass_RDR,ratioDataCon_RDR,addr2Integer_RDR] -- We have to make sure that the Ratio type is imported with -- its constructor, because literals of type Ratio t are -- built with that constructor. diff --git a/ghc/compiler/rename/RnHsSyn.lhs b/ghc/compiler/rename/RnHsSyn.lhs index 58d71289f0..60dfedb452 100644 --- a/ghc/compiler/rename/RnHsSyn.lhs +++ b/ghc/compiler/rename/RnHsSyn.lhs @@ -11,10 +11,10 @@ module RnHsSyn where import HsSyn import HsPragmas ( InstancePragmas, GenPragmas, DataPragmas, ClassPragmas, ClassOpPragmas ) -import TysWiredIn ( tupleTyCon, unboxedTupleTyCon, - listTyCon, charTyCon ) +import TysWiredIn ( tupleTyCon, listTyCon, charTyCon ) import Name ( Name, getName ) import NameSet +import BasicTypes ( Boxity ) import Util import Outputable \end{code} @@ -45,7 +45,7 @@ type RenamedRecordBinds = HsRecordBinds Name RenamedPat type RenamedSig = Sig Name type RenamedStmt = Stmt Name RenamedPat type RenamedFixitySig = FixitySig Name -type RenamedDeprecation = Deprecation Name +type RenamedDeprecation = DeprecDecl Name type RenamedClassOpPragmas = ClassOpPragmas Name type RenamedClassPragmas = ClassPragmas Name @@ -67,27 +67,25 @@ charTyCon_name, listTyCon_name :: Name charTyCon_name = getName charTyCon listTyCon_name = getName listTyCon -tupleTyCon_name :: Bool -> Int -> Name -tupleTyCon_name True n = getName (tupleTyCon n) -tupleTyCon_name False n = getName (unboxedTupleTyCon n) +tupleTyCon_name :: Boxity -> Int -> Name +tupleTyCon_name boxity n = getName (tupleTyCon boxity n) extractHsTyNames :: RenamedHsType -> NameSet extractHsTyNames ty = get ty where - get (MonoTyApp ty1 ty2) = get ty1 `unionNameSets` get ty2 - get (MonoListTy ty) = unitNameSet listTyCon_name + get (HsAppTy ty1 ty2) = get ty1 `unionNameSets` get ty2 + get (HsListTy ty) = unitNameSet listTyCon_name `unionNameSets` get ty - get (MonoTupleTy tys boxed) = unitNameSet (tupleTyCon_name boxed (length tys)) - `unionNameSets` extractHsTyNames_s tys - get (MonoFunTy ty1 ty2) = get ty1 `unionNameSets` get ty2 - get (MonoIParamTy n ty) = get ty - get (MonoDictTy cls tys) = unitNameSet cls `unionNameSets` extractHsTyNames_s tys - get (MonoUsgForAllTy uv ty) = get ty - get (MonoUsgTy u ty) = get ty - get (MonoTyVar tv) = unitNameSet tv + get (HsTupleTy (HsTupCon n _) tys) = unitNameSet n + `unionNameSets` extractHsTyNames_s tys + get (HsFunTy ty1 ty2) = get ty1 `unionNameSets` get ty2 + get (HsPredTy p) = extractHsPredTyNames p + get (HsUsgForAllTy uv ty) = get ty + get (HsUsgTy u ty) = get ty + get (HsTyVar tv) = unitNameSet tv get (HsForAllTy (Just tvs) - ctxt ty) = (extractHsCtxtTyNames ctxt `unionNameSets` get ty) + ctxt ty) = (extractHsCtxtTyNames ctxt `unionNameSets` get ty) `minusNameSet` mkNameSet (map getTyVarName tvs) get ty@(HsForAllTy Nothing _ _) = pprPanic "extractHsTyNames" (ppr ty) diff --git a/ghc/compiler/rename/RnIfaces.lhs b/ghc/compiler/rename/RnIfaces.lhs index 0b6c36894a..71221cee80 100644 --- a/ghc/compiler/rename/RnIfaces.lhs +++ b/ghc/compiler/rename/RnIfaces.lhs @@ -5,13 +5,15 @@ \begin{code} module RnIfaces ( - getInterfaceExports, + findAndReadIface, + + getInterfaceExports, getDeferredDecls, getImportedInstDecls, getImportedRules, - lookupFixity, loadHomeInterface, - importDecl, recordSlurp, - getImportVersions, getSlurped, + lookupFixityRn, loadHomeInterface, + importDecl, ImportDeclResult(..), recordLocalSlurps, loadBuiltinRules, + mkImportExportInfo, getSlurped, - checkUpToDate, + checkModUsage, outOfDate, upToDate, getDeclBinders, getDeclSysBinders, removeContext -- removeContext probably belongs somewhere else @@ -19,20 +21,23 @@ module RnIfaces ( #include "HsVersions.h" -import CmdLineOpts ( opt_NoPruneDecls, opt_IgnoreIfacePragmas ) +import CmdLineOpts ( opt_NoPruneDecls, opt_NoPruneTyDecls, opt_IgnoreIfacePragmas ) import HsSyn ( HsDecl(..), TyClDecl(..), InstDecl(..), IfaceSig(..), HsType(..), ConDecl(..), IE(..), ConDetails(..), Sig(..), ForeignDecl(..), ForKind(..), isDynamicExtName, FixitySig(..), RuleDecl(..), - isClassOpSig, Deprecation(..) + isClassOpSig, DeprecDecl(..) ) +import HsImpExp ( ieNames ) +import CoreSyn ( CoreRule ) import BasicTypes ( Version, NewOrData(..), defaultFixity ) import RdrHsSyn ( RdrNameHsDecl, RdrNameInstDecl, RdrNameTyClDecl, RdrNameRuleDecl, - extractHsTyRdrNames, RdrNameDeprecation + RdrNameFixitySig, RdrNameDeprecation, RdrNameIE, + extractHsTyRdrNames ) -import RnEnv ( mkImportedGlobalName, newImportedBinder, mkImportedGlobalFromRdrName, +import RnEnv ( mkImportedGlobalName, newTopBinder, mkImportedGlobalFromRdrName, lookupOccRn, lookupImplicitOccRn, - pprAvail, + pprAvail, rdrAvailInfo, availName, availNames, addAvailToNameSet, addSysAvails, FreeVars, emptyFVs ) @@ -40,12 +45,8 @@ import RnMonad import RnHsSyn ( RenamedHsDecl, RenamedDeprecation ) import ParseIface ( parseIface, IfaceStuff(..) ) -import FiniteMap ( FiniteMap, sizeFM, emptyFM, delFromFM, listToFM, - lookupFM, addToFM, addToFM_C, addListToFM, - fmToList, elemFM, foldFM - ) -import Name ( Name {-instance NamedThing-}, - nameModule, isLocallyDefined, +import Name ( Name {-instance NamedThing-}, nameOccName, + nameModule, isLocallyDefined, isWiredInName, nameUnique, NamedThing(..) ) import Module ( Module, moduleString, pprModule, @@ -57,18 +58,18 @@ import RdrName ( RdrName, rdrNameOcc ) import NameSet import Var ( Id ) import SrcLoc ( mkSrcLoc, SrcLoc ) -import PrelMods ( pREL_GHC ) -import PrelInfo ( cCallishTyKeys ) -import Bag +import PrelInfo ( pREL_GHC, cCallishTyKeys ) import Maybes ( MaybeErr(..), maybeToBool, orElse ) import ListSetOps ( unionLists ) -import Outputable -import Unique ( Unique ) +import Unique ( Unique, Uniquable(..) ) import StringBuffer ( StringBuffer, hGetStringBuffer ) import FastString ( mkFastString ) import ErrUtils ( Message ) +import Util ( sortLt, lengthExceeds ) import Lex +import FiniteMap import Outputable +import Bag import IO ( isDoesNotExistError ) import List ( nub ) @@ -120,7 +121,7 @@ tryLoadInterface doc_str mod_name from ImportByUserSource -> True ; -- hi-boot ImportBySystem -> case mod_info of - Just (_, _, is_boot, _) -> is_boot + Just (_, is_boot, _) -> is_boot Nothing -> False -- We're importing a module we know absolutely @@ -130,12 +131,12 @@ tryLoadInterface doc_str mod_name from } redundant_source_import = case (from, mod_info) of - (ImportByUserSource, Just (_,_,False,_)) -> True + (ImportByUserSource, Just (_,False,_)) -> True other -> False in -- CHECK WHETHER WE HAVE IT ALREADY case mod_info of { - Just (_, _, _, Just _) + Just (_, _, Just _) -> -- We're read it already so don't re-read it returnRn (ifaces, Nothing) ; @@ -154,7 +155,7 @@ tryLoadInterface doc_str mod_name from -- so that we don't look again let mod = mkVanillaModule mod_name - new_mod_map = addToFM mod_map mod_name (0, False, False, Just (mod, from, [])) + new_mod_map = addToFM mod_map mod_name (False, False, Just (mod, 0, 0, 0, from, [])) new_ifaces = ifaces { iImpModInfo = new_mod_map } in setIfacesRn new_ifaces `thenRn_` @@ -172,8 +173,7 @@ tryLoadInterface doc_str mod_name from getModuleRn `thenRn` \ this_mod_nm -> let - rd_decls = pi_decls iface - mod = pi_mod iface + mod = pi_mod iface in -- 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 @@ -181,16 +181,12 @@ tryLoadInterface doc_str mod_name from case from of { ImportBySystem -> True; other -> False } && isLocalModule mod, ppr mod ) - foldlRn (loadDecl mod) (iDecls ifaces) rd_decls `thenRn` \ new_decls -> - foldlRn (loadInstDecl mod) (iInsts ifaces) (pi_insts iface) `thenRn` \ new_insts -> - (if opt_IgnoreIfacePragmas - then returnRn emptyBag - else foldlRn (loadRule mod) (iRules ifaces) (pi_rules iface)) `thenRn` \ new_rules -> - (if opt_IgnoreIfacePragmas - then returnRn emptyNameEnv - else foldlRn (loadDeprec mod) (iDeprecs ifaces) (pi_deprecs iface)) `thenRn` \ new_deprecs -> - foldlRn (loadFixDecl mod_name) (iFixes ifaces) rd_decls `thenRn` \ new_fixities -> - mapRn (loadExport this_mod_nm) (pi_exports iface) `thenRn` \ avails_s -> + foldlRn (loadDecl mod) (iDecls ifaces) (pi_decls iface) `thenRn` \ new_decls -> + foldlRn (loadInstDecl mod) (iInsts ifaces) (pi_insts iface) `thenRn` \ new_insts -> + loadRules mod (iRules ifaces) (pi_rules iface) `thenRn` \ new_rules -> + loadFixDecls mod_name (iFixes ifaces) (pi_fixity iface) `thenRn` \ new_fixities -> + foldlRn (loadDeprec mod) (iDeprecs ifaces) (pi_deprecs iface) `thenRn` \ new_deprecs -> + mapRn (loadExport this_mod_nm) (pi_exports iface) `thenRn` \ avails_s -> let -- For an explicit user import, add to mod_map info about -- the things the imported module depends on, extracted @@ -201,8 +197,10 @@ tryLoadInterface doc_str mod_name from -- Now add info about this module mod_map2 = addToFM mod_map1 mod_name mod_details - cts = (pi_mod iface, from, concat avails_s) - mod_details = (pi_vers iface, pi_orphan iface, hi_boot_file, Just cts) + cts = (pi_mod iface, pi_vers iface, + fst (pi_fixity iface), fst (pi_rules iface), + from, concat avails_s) + mod_details = (pi_orphan iface, hi_boot_file, Just cts) new_ifaces = ifaces { iImpModInfo = mod_map2, iDecls = new_decls, @@ -215,6 +213,11 @@ tryLoadInterface doc_str mod_name from returnRn (new_ifaces, Nothing) }} +----------------------------------------------------- +-- Adding module dependencies from the +-- import decls in the interface file +----------------------------------------------------- + addModDeps :: Module -> [ImportVersion a] -> ImportedModuleInfo -> ImportedModuleInfo -- (addModDeps M ivs deps) @@ -226,20 +229,25 @@ addModDeps mod new_deps mod_deps -- Except for its descendents which contain orphans, -- and in that case, forget about the boot indicator filtered_new_deps - | isLocalModule mod = [ (imp_mod, (version, has_orphans, is_boot, Nothing)) - | (imp_mod, version, has_orphans, is_boot, _) <- new_deps + | isLocalModule mod = [ (imp_mod, (has_orphans, is_boot, Nothing)) + | (imp_mod, has_orphans, is_boot, _) <- new_deps ] - | otherwise = [ (imp_mod, (version, True, False, Nothing)) - | (imp_mod, version, has_orphans, _, _) <- new_deps, + | otherwise = [ (imp_mod, (True, False, Nothing)) + | (imp_mod, has_orphans, _, _) <- new_deps, has_orphans ] add (imp_mod, dep) deps = addToFM_C combine deps imp_mod dep - combine old@(_, _, old_is_boot, cts) new + combine old@(_, old_is_boot, cts) new | maybeToBool cts || not old_is_boot = old -- Keep the old info if it's already loaded -- or if it's a non-boot pending load | otherwise = new -- Otherwise pick new info + +----------------------------------------------------- +-- Loading the export list +----------------------------------------------------- + loadExport :: ModuleName -> ExportItem -> RnM d [AvailInfo] loadExport this_mod (mod, entities) | mod == this_mod = returnRn [] @@ -273,21 +281,9 @@ loadExport this_mod (mod, entities) returnRn (AvailTC name names) -loadFixDecl :: ModuleName -> FixityEnv - -> (Version, RdrNameHsDecl) - -> RnM d FixityEnv -loadFixDecl mod_name fixity_env (version, FixD sig@(FixitySig rdr_name fixity loc)) - = -- Ignore the version; when the fixity changes the version of - -- its 'host' entity changes, so we don't need a separate version - -- number for fixities - mkImportedGlobalName mod_name (rdrNameOcc rdr_name) `thenRn` \ name -> - let - new_fixity_env = addToNameEnv fixity_env name (FixitySig name fixity loc) - in - returnRn new_fixity_env - - -- Ignore the other sorts of decl -loadFixDecl mod_name fixity_env other_decl = returnRn fixity_env +----------------------------------------------------- +-- Loading type/class/value decls +----------------------------------------------------- loadDecl :: Module -> DeclsMap @@ -318,10 +314,13 @@ loadDecl mod decls_map (version, decl) returnRn new_decls_map } where - -- newImportedBinder puts into the cache the binder with the + -- newTopBinder puts into the cache the binder with the -- module information set correctly. When the decl is later renamed, -- the binding site will thereby get the correct module. - new_name rdr_name loc = newImportedBinder mod rdr_name + -- There maybe occurrences that don't have the correct Module, but + -- by the typechecker will propagate the binding definition to all + -- the occurrences, so that doesn't matter + new_name rdr_name loc = newTopBinder mod (rdrNameOcc rdr_name) {- If a signature decl is being loaded, and optIgnoreIfacePragmas is on, @@ -344,6 +343,26 @@ loadDecl mod decls_map (version, decl) -> SigD (IfaceSig name tp [] loc) other -> decl +----------------------------------------------------- +-- Loading fixity decls +----------------------------------------------------- + +loadFixDecls mod_name fixity_env (version, decls) + | null decls = returnRn fixity_env + + | otherwise + = mapRn (loadFixDecl mod_name) decls `thenRn` \ to_add -> + returnRn (addListToNameEnv fixity_env to_add) + +loadFixDecl mod_name sig@(FixitySig rdr_name fixity loc) + = mkImportedGlobalName mod_name (rdrNameOcc rdr_name) `thenRn` \ name -> + returnRn (name, FixitySig name fixity loc) + + +----------------------------------------------------- +-- Loading instance decls +----------------------------------------------------- + loadInstDecl :: Module -> Bag GatedDecl -> RdrNameInstDecl @@ -375,42 +394,66 @@ loadInstDecl mod insts decl@(InstDecl inst_ty binds uprags dfun_name src_loc) removeContext (HsForAllTy tvs cxt ty) = HsForAllTy tvs [] (removeFuns ty) removeContext ty = removeFuns ty -removeFuns (MonoFunTy _ ty) = removeFuns ty +removeFuns (HsFunTy _ ty) = removeFuns ty removeFuns ty = ty -loadRule :: Module -> Bag GatedDecl - -> RdrNameRuleDecl -> RnM d (Bag GatedDecl) +----------------------------------------------------- +-- Loading Rules +----------------------------------------------------- + +loadRules :: Module -> IfaceRules + -> (Version, [RdrNameRuleDecl]) + -> RnM d IfaceRules +loadRules mod rule_bag (version, rules) + | null rules || opt_IgnoreIfacePragmas + = returnRn rule_bag + | otherwise + = setModuleRn mod_name $ + mapRn (loadRule mod) rules `thenRn` \ new_rules -> + returnRn (rule_bag `unionBags` listToBag new_rules) + where + mod_name = moduleName mod + +loadRule :: Module -> RdrNameRuleDecl -> RnM d GatedDecl -- "Gate" the rule simply by whether the rule variable is -- needed. We can refine this later. -loadRule mod rules decl@(IfaceRuleDecl var body src_loc) - = setModuleRn (moduleName mod) $ - mkImportedGlobalFromRdrName var `thenRn` \ var_name -> - returnRn ((unitNameSet var_name, (mod, RuleD decl)) `consBag` rules) +loadRule mod decl@(IfaceRule _ _ var _ _ src_loc) + = mkImportedGlobalFromRdrName var `thenRn` \ var_name -> + returnRn (unitNameSet var_name, (mod, RuleD decl)) + +loadBuiltinRules :: [(RdrName, CoreRule)] -> RnMG () +loadBuiltinRules builtin_rules + = getIfacesRn `thenRn` \ ifaces -> + mapRn loadBuiltinRule builtin_rules `thenRn` \ rule_decls -> + setIfacesRn (ifaces { iRules = iRules ifaces `unionBags` listToBag rule_decls }) + +loadBuiltinRule (var, rule) + = mkImportedGlobalFromRdrName var `thenRn` \ var_name -> + returnRn (unitNameSet var_name, (nameModule var_name, RuleD (IfaceRuleOut var rule))) + + +----------------------------------------------------- +-- Loading Deprecations +----------------------------------------------------- --- SUP: TEMPORARY HACK, ignoring module deprecations for now loadDeprec :: Module -> DeprecationEnv -> RdrNameDeprecation -> RnM d DeprecationEnv -loadDeprec mod deprec_env (Deprecation (IEModuleContents _) txt) +loadDeprec mod deprec_env (Deprecation (IEModuleContents _) txt _) = traceRn (text "module deprecation not yet implemented:" <+> ppr mod <> colon <+> ppr txt) `thenRn_` + -- SUP: TEMPORARY HACK, ignoring module deprecations for now returnRn deprec_env -loadDeprec mod deprec_env (Deprecation ie txt) + +loadDeprec mod deprec_env (Deprecation ie txt _) = setModuleRn (moduleName mod) $ - mapRn mkImportedGlobalFromRdrName (namesFromIE ie) `thenRn` \ names -> + mapRn mkImportedGlobalFromRdrName (ieNames ie) `thenRn` \ names -> traceRn (text "loaded deprecation(s) for" <+> hcat (punctuate comma (map ppr names)) <> colon <+> ppr txt) `thenRn_` returnRn (extendNameEnv deprec_env (zip names (repeat txt))) - -namesFromIE :: IE a -> [a] -namesFromIE (IEVar n ) = [n] -namesFromIE (IEThingAbs n ) = [n] -namesFromIE (IEThingAll n ) = [n] -namesFromIE (IEThingWith n ns) = n:ns -namesFromIE (IEModuleContents _ ) = [] \end{code} %******************************************************** %* * -\subsection{Loading usage information} +\subsection{Checking usage information} %* * %******************************************************** @@ -418,31 +461,14 @@ namesFromIE (IEModuleContents _ ) = [] upToDate = True outOfDate = False -checkUpToDate :: ModuleName -> RnMG Bool -- True <=> no need to recompile - -- When this guy is called, we already know that the - -- source code is unchanged from last time -checkUpToDate mod_name - = getIfacesRn `thenRn` \ ifaces -> - findAndReadIface doc_str mod_name - False {- Not hi-boot -} `thenRn` \ read_result -> - - -- CHECK WHETHER WE HAVE IT ALREADY - case read_result of - Left err -> -- Old interface file not found, or garbled, so we'd better bail out - traceRn (vcat [ptext SLIT("No old iface") <+> pprModuleName mod_name, - err]) `thenRn_` - returnRn outOfDate - - Right iface - -> -- Found it, so now check it - checkModUsage (pi_usages iface) - where - -- Only look in current directory, with suffix .hi - doc_str = sep [ptext SLIT("need usage info from"), pprModuleName mod_name] +checkModUsage :: [ImportVersion OccName] -> RnMG Bool +-- 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 [] = returnRn upToDate -- Yes! Everything is up to date! -checkModUsage ((mod_name, old_mod_vers, _, _, Specifically []) : rest) +checkModUsage ((mod_name, _, _, NothingAtAll) : rest) -- If CurrentModule.hi contains -- import Foo :: ; -- then that simply records that Foo lies below CurrentModule in the @@ -451,19 +477,25 @@ checkModUsage ((mod_name, old_mod_vers, _, _, Specifically []) : rest) = traceRn (ptext SLIT("Nothing used from:") <+> ppr mod_name) `thenRn_` checkModUsage rest -- This one's ok, so check the rest -checkModUsage ((mod_name, old_mod_vers, _, _, whats_imported) : rest) +checkModUsage ((mod_name, _, _, whats_imported) : rest) = tryLoadInterface doc_str mod_name ImportBySystem `thenRn` \ (ifaces, maybe_err) -> case maybe_err of { - Just err -> traceRn (sep [ptext SLIT("Can't find version number for module"), - pprModuleName mod_name]) `thenRn_` - returnRn outOfDate ; + Just err -> out_of_date (sep [ptext SLIT("Can't find version number for module"), + pprModuleName 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 + Nothing -> let - new_mod_vers = case lookupFM (iImpModInfo ifaces) mod_name of - Just (version, _, _, _) -> version + (_, new_mod_vers, new_fix_vers, new_rule_vers, _, _) + = case lookupFM (iImpModInfo ifaces) mod_name of + Just (_, _, Just stuff) -> stuff + + old_mod_vers = case whats_imported of + Everything v -> v + Specifically v _ _ _ -> v + -- NothingAtAll case dealt with by previous eqn for checkModUsage in -- If the module version hasn't changed, just move on if new_mod_vers == old_mod_vers then @@ -477,19 +509,25 @@ checkModUsage ((mod_name, old_mod_vers, _, _, whats_imported) : rest) -- If the usage info wants to say "I imported everything from this module" -- it does so by making whats_imported equal to Everything -- In that case, we must recompile - case whats_imported of { - Everything -> traceRn (ptext SLIT("...and I needed the whole module")) `thenRn_` - returnRn outOfDate; -- Bale out + case whats_imported of { -- NothingAtAll dealt with earlier + + Everything _ + -> out_of_date (ptext SLIT("...and I needed the whole module")) ; - Specifically old_local_vers -> + Specifically _ old_fix_vers old_rule_vers old_local_vers -> + if old_fix_vers /= new_fix_vers then + out_of_date (ptext SLIT("Fixities changed")) + else if old_rule_vers /= new_rule_vers then + out_of_date (ptext SLIT("Rules changed")) + else -- Non-empty usage list, so check item by item checkEntityUsage mod_name (iDecls ifaces) old_local_vers `thenRn` \ up_to_date -> if up_to_date then traceRn (ptext SLIT("...but the bits I use haven't.")) `thenRn_` checkModUsage rest -- This one's ok, so check the rest else - returnRn outOfDate -- This one failed, so just bail out now + returnRn outOfDate -- This one failed, so just bail out now }} where doc_str = sep [ptext SLIT("need version info for"), pprModuleName mod_name] @@ -503,8 +541,7 @@ checkEntityUsage mod decls ((occ_name,old_vers) : rest) case lookupNameEnv decls name of Nothing -> -- We used it before, but it ain't there now - traceRn (sep [ptext SLIT("No longer exported:"), ppr name]) - `thenRn_` returnRn outOfDate + 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 @@ -513,8 +550,9 @@ checkEntityUsage mod decls ((occ_name,old_vers) : rest) | otherwise -- Out of date, so bale out - -> traceRn (sep [ptext SLIT("Out of date:"), ppr name]) `thenRn_` - returnRn outOfDate + -> out_of_date (sep [ptext SLIT("Out of date:"), ppr name]) + +out_of_date msg = traceRn msg `thenRn_` returnRn outOfDate \end{code} @@ -525,44 +563,111 @@ checkEntityUsage mod decls ((occ_name,old_vers) : rest) %********************************************************* \begin{code} -importDecl :: Name -> RnMG (Maybe (Module, RdrNameHsDecl)) - -- Returns Nothing for - -- (a) wired in name - -- (b) local decl - -- (c) already slurped +importDecl :: Name -> RnMG ImportDeclResult + +data ImportDeclResult + = AlreadySlurped + | WiredIn + | Deferred + | HereItIs (Module, RdrNameHsDecl) importDecl name - | isWiredInName name - = returnRn Nothing - | otherwise = getSlurped `thenRn` \ already_slurped -> if name `elemNameSet` already_slurped then - returnRn Nothing -- Already dealt with - else - if isLocallyDefined name then -- Don't bring in decls from + returnRn AlreadySlurped -- Already dealt with + + else if isLocallyDefined name then -- Don't bring in decls from -- the renamed module's own interface file - addWarnRn (importDeclWarn name) `thenRn_` - returnRn Nothing - else - getNonWiredInDecl name -\end{code} + addWarnRn (importDeclWarn name) `thenRn_` + returnRn AlreadySlurped -\begin{code} -getNonWiredInDecl :: Name -> RnMG (Maybe (Module, RdrNameHsDecl)) + else if isWiredInName name then + -- When we find a wired-in name we must load its + -- home module so that we find any instance decls therein + loadHomeInterface doc name `thenRn_` + returnRn WiredIn + + else getNonWiredInDecl name + where + doc = ptext SLIT("need home module for wired in thing") <+> ppr name + + +{- I don't think this is necessary any more; SLPJ May 00 + load_home name + | name `elemNameSet` source_binders = returnRn () + -- When compiling the prelude, a wired-in thing may + -- be defined in this module, in which case we don't + -- want to load its home module! + -- Using 'isLocallyDefined' doesn't work because some of + -- the free variables returned are simply 'listTyCon_Name', + -- with a system provenance. We could look them up every time + -- but that seems a waste. + | otherwise = loadHomeInterface doc name `thenRn_` + returnRn () +-} + +getNonWiredInDecl :: Name -> RnMG ImportDeclResult getNonWiredInDecl needed_name = traceRn doc_str `thenRn_` loadHomeInterface doc_str needed_name `thenRn` \ ifaces -> case lookupNameEnv (iDecls ifaces) needed_name of + Just (version, avail, is_tycon_name, decl@(_, TyClD (TyData DataType _ _ _ _ ncons _ _ _))) + -- This case deals with deferred import of algebraic data types + + | not opt_NoPruneTyDecls + + && (opt_IgnoreIfacePragmas || ncons > 1) + -- We only defer if imported interface pragmas are ingored + -- or if it's not a product type. + -- Sole reason: The wrapper for a strict function may need to look + -- inside its arg, and hence need to see its arg type's constructors. + + && not (getUnique tycon_name `elem` cCallishTyKeys) + -- Never defer ccall types; we have to unbox them, + -- and importing them does no harm + + -> -- OK, so we're importing a deferrable data type + if needed_name == tycon_name then + -- The needed_name is the TyCon of a data type decl + -- Record that it's slurped, put it in the deferred set + -- and don't return a declaration at all + setIfacesRn (recordSlurp (ifaces {iDeferred = iDeferred ifaces + `addOneToNameSet` tycon_name}) + version (AvailTC needed_name [needed_name])) `thenRn_` + returnRn Deferred + else + -- The needed name is a constructor of a data type decl, + -- getting a constructor, so remove the TyCon from the deferred set + -- (if it's there) and return the full declaration + setIfacesRn (recordSlurp (ifaces {iDeferred = iDeferred ifaces + `delFromNameSet` tycon_name}) + version avail) `thenRn_` + returnRn (HereItIs decl) + where + tycon_name = availName avail + Just (version,avail,_,decl) - -> recordSlurp (Just version) avail `thenRn_` - returnRn (Just decl) + -> setIfacesRn (recordSlurp ifaces version avail) `thenRn_` + returnRn (HereItIs decl) - Nothing -- Can happen legitimately for "Optional" occurrences + Nothing -> addErrRn (getDeclErr needed_name) `thenRn_` - returnRn Nothing + returnRn AlreadySlurped where doc_str = ptext SLIT("need decl for") <+> ppr needed_name + +getDeferredDecls :: RnMG [(Module, RdrNameHsDecl)] +getDeferredDecls + = getIfacesRn `thenRn` \ ifaces -> + let + decls_map = iDecls ifaces + deferred_names = nameSetToList (iDeferred ifaces) + get_abstract_decl n = case lookupNameEnv decls_map n of + Just (_, _, _, decl) -> decl + in + traceRn (sep [text "getDeferredDecls", nest 4 (fsep (map ppr deferred_names))]) `thenRn_` + returnRn (map get_abstract_decl deferred_names) \end{code} @getWiredInDecl@ maps a wired-in @Name@ to what it makes available. @@ -600,7 +705,7 @@ getInterfaceExports :: ModuleName -> WhereFrom -> RnMG (Module, Avails) getInterfaceExports mod_name from = loadInterface doc_str mod_name from `thenRn` \ ifaces -> case lookupFM (iImpModInfo ifaces) mod_name of - Just (_, _, _, Just (mod, _, avails)) -> returnRn (mod, avails) + Just (_, _, Just (mod, _, _, _, _, avails)) -> returnRn (mod, avails) -- loadInterface always puts something in the map -- even if it's a fake where @@ -622,7 +727,7 @@ getImportedInstDecls gates getIfacesRn `thenRn` \ ifaces -> let orphan_mods = - [mod | (mod, (_, True, _, Nothing)) <- fmToList (iImpModInfo ifaces)] + [mod | (mod, (True, _, Nothing)) <- fmToList (iImpModInfo ifaces)] in loadOrphanModules orphan_mods `thenRn_` @@ -655,11 +760,15 @@ getImportedRules = getIfacesRn `thenRn` \ ifaces -> let gates = iSlurp ifaces -- Anything at all that's been slurped - (decls, new_rules) = selectGated gates (iRules ifaces) + rules = iRules ifaces + (decls, new_rules) = selectGated gates rules in - setIfacesRn (ifaces { iRules = new_rules }) `thenRn_` + if null decls then + returnRn [] + else + setIfacesRn (ifaces { iRules = new_rules }) `thenRn_` traceRn (sep [text "getImportedRules:", - text "Slurped" <+> int (length decls) <+> text "rules"]) `thenRn_` + text "Slurped" <+> int (length decls) <+> text "rules"]) `thenRn_` returnRn decls selectGated gates decl_bag @@ -676,13 +785,11 @@ selectGated gates decl_bag | isEmptyNameSet (reqd `minusNameSet` gates) = (decl:yes, no) | otherwise = (yes, (reqd,decl) `consBag` no) -lookupFixity :: Name -> RnMS Fixity -lookupFixity name +lookupFixityRn :: Name -> RnMS Fixity +lookupFixityRn name | isLocallyDefined name = getFixityEnv `thenRn` \ local_fix_env -> - case lookupNameEnv local_fix_env name of - Just (FixitySig _ fix _) -> returnRn fix - Nothing -> returnRn defaultFixity + returnRn (lookupFixity local_fix_env name) | otherwise -- Imported -- For imported names, we have to get their fixities by doing a loadHomeInterface, @@ -693,9 +800,7 @@ lookupFixity name -- 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. = loadHomeInterface doc name `thenRn` \ ifaces -> - case lookupNameEnv (iFixes ifaces) name of - Just (FixitySig _ fix _) -> returnRn fix - Nothing -> returnRn defaultFixity + returnRn (lookupFixity (iFixes ifaces) name) where doc = ptext SLIT("Checking fixity for") <+> ppr name \end{code} @@ -759,20 +864,32 @@ 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. \begin{code} -getImportVersions :: ModuleName -- Name of this module - -> ExportEnv -- Info about exports - -> RnMG (VersionInfo Name) -- Version info for these names - -getImportVersions this_mod (ExportEnv _ _ export_all_mods) +mkImportExportInfo :: ModuleName -- Name of this module + -> Avails -- Info about exports + -> Maybe [RdrNameIE] -- The export header + -> RnMG ([ExportItem], -- Export info for iface file; sorted + [ImportVersion OccName]) -- Import info for iface file; sorted + -- Both results are sorted into canonical order to + -- reduce needless wobbling of interface files + +mkImportExportInfo this_mod export_avails exports = getIfacesRn `thenRn` \ ifaces -> let + export_all_mods = case exports of + Nothing -> [] + Just es -> [mod | IEModuleContents mod <- es, + mod /= this_mod] + mod_map = iImpModInfo ifaces imp_names = iVSlurp ifaces -- mv_map groups together all the things imported from a particular module. - mv_map :: FiniteMap ModuleName [(Name,Version)] + mv_map :: FiniteMap ModuleName [(OccName,Version)] mv_map = foldr add_mv emptyFM imp_names + add_mv (name, version) mv_map = addItem mv_map (moduleName (nameModule name)) + (nameOccName name, version) + -- Build the result list by adding info for each module. -- For (a) a library module, we don't record it at all unless it contains orphans -- (We must never lose track of orphans.) @@ -789,7 +906,7 @@ getImportVersions this_mod (ExportEnv _ _ export_all_mods) -- whether something is a boot file along with the usage info for it, but -- I can't be bothered just now. - mk_version_info mod_name (version, has_orphans, is_boot, contents) so_far + mk_imp_info mod_name (has_orphans, is_boot, contents) so_far | mod_name == this_mod -- Check if M appears in the set of modules 'below' M -- This seems like a convenient place to check = WARN( not is_boot, ptext SLIT("Wierd:") <+> ppr this_mod <+> @@ -798,7 +915,7 @@ getImportVersions this_mod (ExportEnv _ _ export_all_mods) | otherwise = let - go_for_it exports = (mod_name, version, has_orphans, is_boot, exports) + go_for_it exports = (mod_name, has_orphans, is_boot, exports) : so_far in case contents of @@ -809,20 +926,21 @@ getImportVersions this_mod (ExportEnv _ _ export_all_mods) -- information. The Nothing says that we didn't even open the interface -- file but we must still propagate the dependeny info. -- The module in question must be a local module (in the same package) - go_for_it (Specifically []) + go_for_it NothingAtAll - Just (mod, how_imported, _) + Just (mod, mod_vers, fix_vers, rule_vers, how_imported, _) | is_sys_import && is_lib_module && not has_orphans -> so_far | is_lib_module -- Record the module but not detailed || mod_name `elem` export_all_mods -- version information for the imports - -> go_for_it Everything + -> go_for_it (Everything mod_vers) | otherwise -> case lookupFM mv_map mod_name of - Just whats_imported -> go_for_it (Specifically whats_imported) - Nothing -> go_for_it (Specifically []) + Just whats_imported -> go_for_it (Specifically mod_vers fix_vers rule_vers + (sortImport whats_imported)) + Nothing -> go_for_it NothingAtAll -- This happens if you have -- import Foo -- but don't actually *use* anything from Foo @@ -833,15 +951,36 @@ getImportVersions this_mod (ExportEnv _ _ export_all_mods) ImportBySystem -> True other -> False + + import_info = foldFM mk_imp_info [] mod_map + + -- Sort exports into groups by module + export_fm :: FiniteMap ModuleName [RdrAvailInfo] + export_fm = foldr insert emptyFM export_avails + + insert avail efm = addItem efm (moduleName (nameModule (availName avail))) + (rdrAvailInfo avail) + + export_info = [(m, sortExport as) | (m,as) <- fmToList export_fm] in + returnRn (export_info, import_info) - returnRn (foldFM mk_version_info [] mod_map) - where - add_mv v@(name, version) mv_map - = addToFM_C add_item mv_map mod [v] - where - mod = moduleName (nameModule name) - add_item vs _ = (v:vs) + +addItem :: FiniteMap ModuleName [a] -> ModuleName -> a -> FiniteMap ModuleName [a] +addItem fm mod x = addToFM_C add_item fm mod [x] + where + add_item xs _ = x:xs + +sortImport :: [(OccName,Version)] -> [(OccName,Version)] + -- Make the usage lists appear in canonical order +sortImport vs = sortLt lt vs + where + lt (n1,v1) (n2,v2) = n1 < n2 + +sortExport :: [RdrAvailInfo] -> [RdrAvailInfo] +sortExport as = sortLt lt as + where + lt a1 a2 = availName a1 < availName a2 \end{code} \begin{code} @@ -849,20 +988,20 @@ getSlurped = getIfacesRn `thenRn` \ ifaces -> returnRn (iSlurp ifaces) -recordSlurp maybe_version avail --- Nothing for locally defined names --- Just version for imported names - = getIfacesRn `thenRn` \ ifaces@(Ifaces { iSlurp = slurped_names, - iVSlurp = imp_names }) -> - let +recordSlurp ifaces@(Ifaces { iSlurp = slurped_names, iVSlurp = imp_names }) + version avail + = let new_slurped_names = addAvailToNameSet slurped_names avail + new_imp_names = (availName avail, version) : imp_names + in + ifaces { iSlurp = new_slurped_names, iVSlurp = new_imp_names } - new_imp_names = case maybe_version of - Just version -> (availName avail, version) : imp_names - Nothing -> imp_names +recordLocalSlurps local_avails + = getIfacesRn `thenRn` \ ifaces -> + let + new_slurped_names = foldl addAvailToNameSet (iSlurp ifaces) local_avails in - setIfacesRn (ifaces { iSlurp = new_slurped_names, - iVSlurp = new_imp_names }) + setIfacesRn (ifaces { iSlurp = new_slurped_names }) \end{code} @@ -884,7 +1023,7 @@ getDeclBinders :: (RdrName -> SrcLoc -> RnM d Name) -- New-name function -> RdrNameHsDecl -> RnM d (Maybe AvailInfo) -getDeclBinders new_name (TyClD (TyData _ _ tycon _ condecls _ _ src_loc)) +getDeclBinders new_name (TyClD (TyData _ _ tycon _ condecls _ _ _ src_loc)) = new_name tycon src_loc `thenRn` \ tycon_name -> getConFieldNames new_name condecls `thenRn` \ sub_names -> returnRn (Just (AvailTC tycon_name (tycon_name : nub sub_names))) @@ -911,7 +1050,8 @@ getDeclBinders new_name (SigD (IfaceSig var ty prags src_loc)) = new_name var src_loc `thenRn` \ var_name -> returnRn (Just (Avail var_name)) -getDeclBinders new_name (FixD _) = returnRn Nothing +getDeclBinders new_name (FixD _) = returnRn Nothing +getDeclBinders new_name (DeprecD _) = returnRn Nothing -- foreign declarations getDeclBinders new_name (ForD (ForeignDecl nm kind _ dyn _ loc)) @@ -967,7 +1107,7 @@ bindings of their own elsewhere. getDeclSysBinders new_name (TyClD (ClassDecl _ cname _ _ sigs _ _ tname dname dwname snames src_loc)) = sequenceRn [new_name n src_loc | n <- (tname : dname : dwname : snames)] -getDeclSysBinders new_name (TyClD (TyData _ _ _ _ cons _ _ _)) +getDeclSysBinders new_name (TyClD (TyData _ _ _ _ cons _ _ _ _)) = sequenceRn [new_name wkr_name src_loc | ConDecl _ wkr_name _ _ _ src_loc <- cons] getDeclSysBinders new_name other_decl diff --git a/ghc/compiler/rename/RnMonad.lhs b/ghc/compiler/rename/RnMonad.lhs index 5a7ea505a6..950fe4849a 100644 --- a/ghc/compiler/rename/RnMonad.lhs +++ b/ghc/compiler/rename/RnMonad.lhs @@ -6,10 +6,13 @@ \begin{code} module RnMonad( module RnMonad, + + module RdrName, -- Re-exports + module Name, -- from these two + Module, FiniteMap, Bag, - Name, RdrNameHsDecl, RdrNameInstDecl, Version, @@ -32,33 +35,37 @@ import IOExts ( IORef, newIORef, readIORef, writeIORef, unsafePerformIO ) import HsSyn import RdrHsSyn import RnHsSyn ( RenamedFixitySig, RenamedDeprecation ) -import BasicTypes ( Version ) +import BasicTypes ( Version, defaultFixity ) import SrcLoc ( noSrcLoc ) import ErrUtils ( addShortErrLocLine, addShortWarnLocLine, pprBagOfErrors, ErrMsg, WarnMsg, Message ) -import Name ( Name, OccName, NamedThing(..), +import RdrName ( RdrName, dummyRdrVarName, rdrNameOcc, + RdrNameEnv, emptyRdrEnv, extendRdrEnv, + lookupRdrEnv, addListToRdrEnv, rdrEnvToList, rdrEnvElts + ) +import Name ( Name, OccName, NamedThing(..), getSrcLoc, isLocallyDefinedName, nameModule, nameOccName, - decode, mkLocalName, mkUnboundName + decode, mkLocalName, mkUnboundName, + NameEnv, lookupNameEnv, emptyNameEnv, unitNameEnv, extendNameEnv, + addToNameEnv_C, plusNameEnv_C, nameEnvElts, + elemNameEnv, addToNameEnv, addListToNameEnv ) import Module ( Module, ModuleName, ModuleHiMap, SearchPath, WhereFrom, - mkModuleHiMaps, moduleName, mkVanillaModule, mkSearchPath + mkModuleHiMaps, moduleName, mkSearchPath ) import NameSet -import RdrName ( RdrName, dummyRdrVarName, rdrNameOcc ) import CmdLineOpts ( opt_D_dump_rn_trace, opt_HiMap ) import PrelInfo ( builtinNames ) import TysWiredIn ( boolTyCon ) import SrcLoc ( SrcLoc, mkGeneratedSrcLoc ) import Unique ( Unique, getUnique, unboundKey ) -import UniqFM ( UniqFM ) import FiniteMap ( FiniteMap, emptyFM, bagToFM, lookupFM, addToFM, addListToFM, addListToFM_C, addToFM_C, eltsFM, fmToList ) import Bag ( Bag, mapBag, emptyBag, isEmptyBag, snocBag ) import Maybes ( mapMaybe ) import UniqSet -import UniqFM import UniqSupply import Util import Outputable @@ -148,57 +155,23 @@ data RnMode = SourceMode -- Renaming source code \begin{code} -------------------------------- -type RdrNameEnv a = FiniteMap RdrName a type GlobalRdrEnv = RdrNameEnv [Name] -- The list is because there may be name clashes -- These only get reported on lookup, -- not on construction type LocalRdrEnv = RdrNameEnv Name -emptyRdrEnv :: RdrNameEnv a -lookupRdrEnv :: RdrNameEnv a -> RdrName -> Maybe a -addListToRdrEnv :: RdrNameEnv a -> [(RdrName,a)] -> RdrNameEnv a -extendRdrEnv :: RdrNameEnv a -> RdrName -> a -> RdrNameEnv a - -emptyRdrEnv = emptyFM -lookupRdrEnv = lookupFM -addListToRdrEnv = addListToFM -rdrEnvElts = eltsFM -extendRdrEnv = addToFM -rdrEnvToList = fmToList - --------------------------------- -type NameEnv a = UniqFM a -- Domain is Name - -emptyNameEnv :: NameEnv a -nameEnvElts :: NameEnv a -> [a] -addToNameEnv_C :: (a->a->a) -> NameEnv a -> Name -> a -> NameEnv a -addToNameEnv :: NameEnv a -> Name -> a -> NameEnv a -plusNameEnv :: NameEnv a -> NameEnv a -> NameEnv a -plusNameEnv_C :: (a->a->a) -> NameEnv a -> NameEnv a -> NameEnv a -extendNameEnv :: NameEnv a -> [(Name,a)] -> NameEnv a -lookupNameEnv :: NameEnv a -> Name -> Maybe a -delFromNameEnv :: NameEnv a -> Name -> NameEnv a -elemNameEnv :: Name -> NameEnv a -> Bool -unitNameEnv :: Name -> a -> NameEnv a - -emptyNameEnv = emptyUFM -nameEnvElts = eltsUFM -addToNameEnv_C = addToUFM_C -addToNameEnv = addToUFM -plusNameEnv = plusUFM -plusNameEnv_C = plusUFM_C -extendNameEnv = addListToUFM -lookupNameEnv = lookupUFM -delFromNameEnv = delFromUFM -elemNameEnv = elemUFM -unitNameEnv = unitUFM - -------------------------------- type FixityEnv = NameEnv RenamedFixitySig -- We keep the whole fixity sig so that we -- can report line-number info when there is a duplicate -- fixity declaration +lookupFixity :: FixityEnv -> Name -> Fixity +lookupFixity env name + = case lookupNameEnv env name of + Just (FixitySig _ fix _) -> fix + Nothing -> defaultFixity + -------------------------------- type DeprecationEnv = NameEnv DeprecTxt \end{code} @@ -229,12 +202,7 @@ type RnNameSupply -------------------------------- -data ExportEnv = ExportEnv Avails Fixities [ModuleName] - -- The list of modules is the modules exported - -- with 'module M' in the export list - type Avails = [AvailInfo] -type Fixities = [(Name, Fixity)] type ExportAvails = (FiniteMap ModuleName Avails, -- Used to figure out "module M" export specifiers @@ -250,6 +218,8 @@ data GenAvailInfo name = Avail name -- An ordinary identifier -- NB: If the type or class is itself -- to be in scope, it must be in this list. -- Thus, typically: AvailTC Eq [Eq, ==, /=] + deriving( Eq ) + -- Equality used when deciding if the interface has changed type AvailEnv = NameEnv AvailInfo -- Maps a Name to the AvailInfo that contains it type AvailInfo = GenAvailInfo Name @@ -262,10 +232,12 @@ type RdrAvailInfo = GenAvailInfo OccName \begin{code} type ExportItem = (ModuleName, [RdrAvailInfo]) -type VersionInfo name = [ImportVersion name] -type ImportVersion name = (ModuleName, Version, - WhetherHasOrphans, IsBootInterface, WhatsImported name) +type ImportVersion name = (ModuleName, WhetherHasOrphans, IsBootInterface, WhatsImported name) + +type ModVersionInfo = (Version, -- Version of the whole module + Version, -- Version number for all fixity decls together + Version) -- ...ditto all rules together type WhetherHasOrphans = Bool -- An "orphan" is @@ -276,15 +248,25 @@ type WhetherHasOrphans = Bool type IsBootInterface = Bool -data WhatsImported name = Everything - | Specifically [LocalVersion name] -- List guaranteed non-empty +data WhatsImported name = NothingAtAll -- The module is below us in the + -- hierarchy, but we import nothing - -- ("M", hif, ver, Everything) means there was a "module M" in - -- this module's export list, so we just have to go by M's version, "ver", - -- not the list of LocalVersions. + | Everything Version -- The module version + | Specifically Version -- Module version + Version -- Fixity version + Version -- Rules version + [(name,Version)] -- List guaranteed non-empty + deriving( Eq ) + -- 'Specifically' doesn't let you say "I imported f but none of the fixities in + -- the module. If you use anything in the module you get its fixity and rule version + -- So if the fixities or rules change, you'll recompile, even if you don't use either. + -- This is easy to implement, and it's safer: you might not have used the rules last + -- time round, but if someone has added a new rule you might need it this time -type LocalVersion name = (name, Version) + -- 'Everything' means there was a "module M" in + -- this module's export list, so we just have to go by M's version, + -- not the list of (name,version) pairs data ParsedIface = ParsedIface { @@ -293,23 +275,13 @@ data ParsedIface pi_orphan :: WhetherHasOrphans, -- Whether this module has orphans pi_usages :: [ImportVersion OccName], -- Usages pi_exports :: [ExportItem], -- Exports - pi_decls :: [(Version, RdrNameHsDecl)], -- Local definitions pi_insts :: [RdrNameInstDecl], -- Local instance declarations - pi_rules :: [RdrNameRuleDecl], -- Rules + pi_decls :: [(Version, RdrNameHsDecl)], -- Local definitions + pi_fixity :: (Version, [RdrNameFixitySig]), -- Local fixity declarations, with their version + pi_rules :: (Version, [RdrNameRuleDecl]), -- Rules, with their version pi_deprecs :: [RdrNameDeprecation] -- Deprecations } -data InterfaceDetails - = InterfaceDetails WhetherHasOrphans - (VersionInfo Name) -- Version information for what this module imports - ExportEnv -- What modules this one depends on - [Deprecation Name] - - --- needed by Main to fish out the fixities assoc list. -getIfaceFixities :: InterfaceDetails -> Fixities -getIfaceFixities (InterfaceDetails _ _ (ExportEnv _ fs _) _) = fs - type RdrNamePragma = () -- Fudge for now ------------------- @@ -323,8 +295,14 @@ data Ifaces = Ifaces { iDecls :: DeclsMap, -- A single, global map of Names to decls - iFixes :: FixityEnv, -- A single, global map of Names to fixities - -- See comments with RnIfaces.lookupFixity + iDeferred :: NameSet, -- data (not newtype) TyCons that have been slurped, + -- but none of their constructors have. + -- If this is still the case right at the end + -- we can get away with importing them abstractly + + iFixes :: FixityEnv, + -- A single, global map of Names to fixities + -- See comments with RnIfaces.lookupFixity iSlurp :: NameSet, -- All the names (whether "big" or "small", whether wired-in or not, @@ -342,17 +320,24 @@ data Ifaces = Ifaces { -- Each is 'gated' by the names that must be available before -- this instance decl is needed. - iRules :: Bag GatedDecl, - -- Ditto transformation rules + iRules :: IfaceRules, + -- Similar to instance decls, except that we track the version number of the + -- rules we import from each module + -- [We keep just one rule-version number for each module] + -- The Bool is True if we import any rules at all from that module iDeprecs :: DeprecationEnv } +type IfaceRules = Bag GatedDecl + type GatedDecl = (NameSet, (Module, RdrNameHsDecl)) type ImportedModuleInfo - = FiniteMap ModuleName (Version, WhetherHasOrphans, IsBootInterface, - Maybe (Module, WhereFrom, Avails)) + = FiniteMap ModuleName (WhetherHasOrphans, IsBootInterface, + Maybe (Module, Version, Version, Version, WhereFrom, Avails)) + -- The three Versions are module version, fixity version, rules version + -- Suppose the domain element is module 'A' -- -- The first Bool is True if A contains @@ -427,6 +412,7 @@ initIfaceRnMS mod thing_inside emptyIfaces :: Ifaces emptyIfaces = Ifaces { iImpModInfo = emptyFM, iDecls = emptyNameEnv, + iDeferred = emptyNameSet, iFixes = emptyNameEnv, iSlurp = unitNameSet (mkUnboundName dummyRdrVarName), -- Pretend that the dummy unbound name has already been diff --git a/ghc/compiler/rename/RnNames.lhs b/ghc/compiler/rename/RnNames.lhs index ba7cbc62bc..979bc00861 100644 --- a/ghc/compiler/rename/RnNames.lhs +++ b/ghc/compiler/rename/RnNames.lhs @@ -24,14 +24,13 @@ import RdrHsSyn ( RdrNameIE, RdrNameImportDecl, RdrNameHsModule, RdrNameHsDecl ) import RnIfaces ( getInterfaceExports, getDeclBinders, getDeclSysBinders, - recordSlurp, checkUpToDate + recordLocalSlurps, checkModUsage, findAndReadIface, outOfDate ) import RnEnv import RnMonad import FiniteMap -import PrelMods -import PrelInfo ( main_RDR ) +import PrelInfo ( pRELUDE_Name, mAIN_Name, main_RDR ) import UniqFM ( lookupUFM ) import Bag ( bagToList ) import Module ( ModuleName, mkThisModule, pprModuleName, WhereFrom(..) ) @@ -40,7 +39,7 @@ import Name ( Name, ExportFlag(..), ImportReason(..), Provenance(..), isLocallyDefined, setNameProvenance, nameOccName, getSrcLoc, pprProvenance, getNameProvenance ) -import RdrName ( RdrName, rdrNameOcc, setRdrNameOcc, mkRdrQual, mkRdrUnqual, isQual ) +import RdrName ( RdrName, rdrNameOcc, setRdrNameOcc, mkRdrQual, mkRdrUnqual, isQual, isUnqual ) import OccName ( setOccNameSpace, dataName ) import SrcLoc ( SrcLoc ) import NameSet ( elemNameSet, emptyNameSet ) @@ -62,25 +61,26 @@ import List ( partition ) \begin{code} getGlobalNames :: RdrNameHsModule - -> RnMG (Maybe (ExportEnv, - GlobalRdrEnv, - FixityEnv, -- Fixities for local decls only - AvailEnv -- Maps a name to its parent AvailInfo - -- Just for in-scope things only + -> RnMG (Maybe (GlobalRdrEnv, -- Maps all in-scope things + GlobalRdrEnv, -- Maps just *local* things + Avails, -- The exported stuff + AvailEnv, -- Maps a name to its parent AvailInfo + -- Just for in-scope things only + Maybe ParsedIface -- The old interface file, if any )) -- Nothing => no need to recompile getGlobalNames (HsModule this_mod _ exports imports decls _ mod_loc) = -- These two fix-loops are to get the right -- provenance information into a Name - fixRn (\ ~(rec_gbl_env, rec_exported_avails, _) -> + fixRn ( \ ~(Just (rec_gbl_env, _, rec_export_avails, _, _)) -> let rec_unqual_fn :: Name -> Bool -- Is this chap in scope unqualified? rec_unqual_fn = unQualInScope rec_gbl_env rec_exp_fn :: Name -> ExportFlag - rec_exp_fn = mk_export_fn (availsToNameSet rec_exported_avails) + rec_exp_fn = mk_export_fn (availsToNameSet rec_export_avails) in setModuleRn this_mod $ @@ -113,74 +113,54 @@ getGlobalNames (HsModule this_mod _ exports imports decls _ mod_loc) all_avails :: ExportAvails all_avails = foldr plusExportAvails local_mod_avails (imp_avails_s2 ++ imp_avails_s1) + (_, global_avail_env) = all_avails in - -- TRY FOR EARLY EXIT - -- We can't go for an early exit before this because we have to check - -- for name clashes. Consider: - -- - -- module A where module B where - -- import B h = True - -- f = h - -- - -- Suppose I've compiled everything up, and then I add a - -- new definition to module B, that defines "f". - -- - -- Then I must detect the name clash in A before going for an early - -- exit. The early-exit code checks what's actually needed from B - -- to compile A, and of course that doesn't include B.f. That's - -- why we wait till after the plusEnv stuff to do the early-exit. - checkEarlyExit this_mod `thenRn` \ up_to_date -> - if up_to_date then - returnRn (gbl_env, junk_exp_fn, Nothing) - else - - -- RECORD BETTER PROVENANCES IN THE CACHE - -- The names in the envirnoment have better provenances (e.g. imported on line x) - -- than the names in the name cache. We update the latter now, so that we - -- we start renaming declarations we'll get the good names - -- The isQual is because the qualified name is always in scope - updateProvenances (concat [names | (rdr_name, names) <- rdrEnvToList imp_gbl_env, - isQual rdr_name]) `thenRn_` - - -- PROCESS EXPORT LISTS - exportsFromAvail this_mod exports all_avails gbl_env `thenRn` \ exported_avails -> - - -- DONE - returnRn (gbl_env, exported_avails, Just all_avails) - ) `thenRn` \ (gbl_env, exported_avails, maybe_stuff) -> - - case maybe_stuff of { - Nothing -> returnRn Nothing ; - Just all_avails -> - - -- DEAL WITH FIXITIES - fixitiesFromLocalDecls gbl_env decls `thenRn` \ local_fixity_env -> - let - -- Export only those fixities that are for names that are - -- (a) defined in this module - -- (b) exported - exported_fixities :: [(Name,Fixity)] - exported_fixities = [(name,fixity) - | FixitySig name fixity _ <- nameEnvElts local_fixity_env, - isLocallyDefined name - ] - - -- CONSTRUCT RESULTS - export_mods = case exports of - Nothing -> [] - Just es -> [mod | IEModuleContents mod <- es, mod /= this_mod] - - export_env = ExportEnv exported_avails exported_fixities export_mods - (_, global_avail_env) = all_avails - in - traceRn (text "fixity env" <+> vcat (map ppr (nameEnvElts local_fixity_env))) `thenRn_` - - returnRn (Just (export_env, gbl_env, local_fixity_env, global_avail_env)) - } + -- TRY FOR EARLY EXIT + -- We can't go for an early exit before this because we have to check + -- for name clashes. Consider: + -- + -- module A where module B where + -- import B h = True + -- f = h + -- + -- Suppose I've compiled everything up, and then I add a + -- new definition to module B, that defines "f". + -- + -- Then I must detect the name clash in A before going for an early + -- exit. The early-exit code checks what's actually needed from B + -- to compile A, and of course that doesn't include B.f. That's + -- why we wait till after the plusEnv stuff to do the early-exit. + + -- Check For eacly exit + checkErrsRn `thenRn` \ no_errs_so_far -> + if not no_errs_so_far then + -- Found errors already, so exit now + returnRn Nothing + else + checkEarlyExit this_mod `thenRn` \ (up_to_date, old_iface) -> + if up_to_date then + -- Interface files are sufficiently unchanged + putDocRn (text "Compilation IS NOT required") `thenRn_` + returnRn Nothing + else + + -- RECORD BETTER PROVENANCES IN THE CACHE + -- The names in the envirnoment have better provenances (e.g. imported on line x) + -- than the names in the name cache. We update the latter now, so that we + -- we start renaming declarations we'll get the good names + -- The isQual is because the qualified name is always in scope + updateProvenances (concat [names | (rdr_name, names) <- rdrEnvToList gbl_env, + isQual rdr_name]) `thenRn_` + + -- PROCESS EXPORT LISTS + exportsFromAvail this_mod exports all_avails gbl_env `thenRn` \ export_avails -> + + + -- ALL DONE + returnRn (Just (gbl_env, local_gbl_env, export_avails, global_avail_env, old_iface)) + ) where - junk_exp_fn = error "RnNames:export_fn" - all_imports = prel_imports ++ imports -- NB: opt_NoImplicitPrelude is slightly different to import Prelude (); @@ -203,27 +183,32 @@ getGlobalNames (HsModule this_mod _ exports imports decls _ mod_loc) \end{code} \begin{code} -checkEarlyExit mod - = checkErrsRn `thenRn` \ no_errs_so_far -> - if not no_errs_so_far then - -- Found errors already, so exit now - returnRn True - else - - traceRn (text "Considering whether compilation is required...") `thenRn_` - if not opt_SourceUnchanged then - -- Source code changed and no errors yet... carry on - traceRn (nest 4 (text "source file changed or recompilation check turned off")) `thenRn_` - returnRn False - else - - -- Unchanged source, and no errors yet; see if usage info - -- up to date, and exit if so - checkUpToDate mod `thenRn` \ up_to_date -> - (if up_to_date - then putDocRn (text "Compilation IS NOT required") - else returnRn ()) `thenRn_` - returnRn up_to_date +checkEarlyExit mod_name + = traceRn (text "Considering whether compilation is required...") `thenRn_` + + -- Read the old interface file, if any, for the module being compiled + findAndReadIface doc_str mod_name False {- Not hi-boot -} `thenRn` \ maybe_iface -> + + -- CHECK WHETHER WE HAVE IT ALREADY + case maybe_iface of + Left err -> -- Old interface file not found, so we'd better bail out + traceRn (vcat [ptext SLIT("No old interface file for") <+> pprModuleName mod_name, + err]) `thenRn_` + returnRn (outOfDate, Nothing) + + Right iface + | not opt_SourceUnchanged + -> -- Source code changed + traceRn (nest 4 (text "source file changed or recompilation check turned off")) `thenRn_` + returnRn (False, Just iface) + + | otherwise + -> -- Source code unchanged and no errors yet... carry on + checkModUsage (pi_usages iface) `thenRn` \ up_to_date -> + returnRn (up_to_date, Just iface) + where + -- Only look in current directory, with suffix .hi + doc_str = sep [ptext SLIT("need usage info from"), pprModuleName mod_name] \end{code} \begin{code} @@ -285,7 +270,7 @@ importsFromLocalDecls mod_name rec_exp_fn decls mapRn_ (addErrRn . dupDeclErr) dups `thenRn_` -- Record that locally-defined things are available - mapRn_ (recordSlurp Nothing) avails `thenRn_` + recordLocalSlurps avails `thenRn_` -- Build the environment qualifyImports mod_name @@ -298,15 +283,16 @@ importsFromLocalDecls mod_name rec_exp_fn decls mod = mkThisModule mod_name newLocalName rdr_name loc - = (if isQual rdr_name then - qualNameErr (text "the binding for" <+> quotes (ppr rdr_name)) (rdr_name,loc) - -- There should never be a qualified name in a binding position (except in instance decls) - -- The parser doesn't check this because the same parser parses instance decls - else - returnRn ()) `thenRn_` - - newLocalTopBinder mod (rdrNameOcc rdr_name) rec_exp_fn loc + = check_unqual rdr_name loc `thenRn_` + newTopBinder mod (rdrNameOcc rdr_name) `thenRn` \ name -> + returnRn (setNameProvenance name (LocalDef loc (rec_exp_fn name))) + -- There should never be a qualified name in a binding position (except in instance decls) + -- The parser doesn't check this because the same parser parses instance decls + check_unqual rdr_name loc + | isUnqual rdr_name = returnRn () + | otherwise = qualNameErr (text "the binding for" <+> quotes (ppr rdr_name)) + (rdr_name,loc) getLocalDeclBinders :: (RdrName -> SrcLoc -> RnMG Name) -- New-name function -> RdrNameHsDecl @@ -327,38 +313,6 @@ getLocalDeclBinders new_name decl -- The getDeclSysBinders is just to get the names of superclass selectors -- etc, into the cache new_sys_name rdr_name loc = newImplicitBinder (rdrNameOcc rdr_name) loc - -fixitiesFromLocalDecls :: GlobalRdrEnv -> [RdrNameHsDecl] -> RnMG FixityEnv -fixitiesFromLocalDecls gbl_env decls - = foldlRn getFixities emptyNameEnv decls - where - getFixities :: FixityEnv -> RdrNameHsDecl -> RnMG FixityEnv - getFixities acc (FixD fix) - = fix_decl acc fix - - getFixities acc (TyClD (ClassDecl _ _ _ _ sigs _ _ _ _ _ _ _)) - = foldlRn fix_decl acc [sig | FixSig sig <- sigs] - -- Get fixities from class decl sigs too. - getFixities acc other_decl - = returnRn acc - - fix_decl acc sig@(FixitySig rdr_name fixity loc) - = -- Check for fixity decl for something not declared - case lookupRdrEnv gbl_env rdr_name of { - Nothing | opt_WarnUnusedBinds - -> pushSrcLocRn loc (addWarnRn (unusedFixityDecl rdr_name fixity)) - `thenRn_` returnRn acc - | otherwise -> returnRn acc ; - - Just (name:_) -> - - -- Check for duplicate fixity decl - case lookupNameEnv acc name of { - Just (FixitySig _ _ loc') -> addErrRn (dupFixityDecl rdr_name loc loc') - `thenRn_` returnRn acc ; - - Nothing -> returnRn (addToNameEnv acc name (FixitySig name fixity loc)) - }} \end{code} %************************************************************************ @@ -750,12 +704,4 @@ dupModuleExport mod = hsep [ptext SLIT("Duplicate"), quotes (ptext SLIT("Module") <+> pprModuleName mod), ptext SLIT("in export list")] - -unusedFixityDecl rdr_name fixity - = hsep [ptext SLIT("Unused fixity declaration for"), quotes (ppr rdr_name)] - -dupFixityDecl rdr_name loc1 loc2 - = vcat [ptext SLIT("Multiple fixity declarations for") <+> quotes (ppr rdr_name), - ptext SLIT("at ") <+> ppr loc1, - ptext SLIT("and") <+> ppr loc2] \end{code} diff --git a/ghc/compiler/rename/RnSource.lhs b/ghc/compiler/rename/RnSource.lhs index 40be2b7287..ccd609623d 100644 --- a/ghc/compiler/rename/RnSource.lhs +++ b/ghc/compiler/rename/RnSource.lhs @@ -4,15 +4,15 @@ \section[RnSource]{Main pass of renamer} \begin{code} -module RnSource ( rnDecl, rnSourceDecls, rnHsType, rnHsSigType, rnHsPolyType ) where +module RnSource ( rnDecl, rnSourceDecls, rnHsType, rnHsSigType ) where #include "HsVersions.h" import RnExpr import HsSyn import HsPragmas -import HsTypes ( getTyVarName, pprHsPred, cmpHsTypes ) -import RdrName ( RdrName, isRdrDataCon, rdrNameOcc, isRdrTyVar ) +import HsTypes ( getTyVarName ) +import RdrName ( RdrName, isRdrDataCon, rdrNameOcc, isRdrTyVar, mkRdrNameWkr ) import RdrHsSyn ( RdrNameContext, RdrNameHsType, RdrNameConDecl, extractRuleBndrsTyVars, extractHsTyRdrTyVars, extractHsTysRdrTyVars ) @@ -21,7 +21,7 @@ import HsCore import RnBinds ( rnTopBinds, rnMethodBinds, renameSigs, unknownSigErr ) import RnEnv ( bindTyVarsRn, lookupBndrRn, lookupOccRn, getIPName, - lookupImplicitOccRn, + lookupImplicitOccRn, lookupImplicitOccsRn, bindLocalsRn, bindLocalRn, bindLocalsFVRn, bindUVarRn, bindTyVarsFVRn, bindTyVarsFV2Rn, extendTyVarEnvFVRn, bindCoreLocalFVRn, bindCoreLocalsFVRn, @@ -33,6 +33,7 @@ import RnEnv ( bindTyVarsRn, lookupBndrRn, lookupOccRn, getIPName, import RnMonad import FunDeps ( oclose ) +import Class ( FunDep ) import Name ( Name, OccName, ExportFlag(..), Provenance(..), @@ -42,8 +43,8 @@ import NameSet import OccName ( mkDefaultMethodOcc ) import BasicTypes ( TopLevelFlag(..) ) import FiniteMap ( elemFM ) -import PrelInfo ( derivableClassKeys, - deRefStablePtr_NAME, makeStablePtr_NAME, bindIO_NAME, returnIO_NAME +import PrelInfo ( derivableClassKeys, cCallishClassKeys, + deRefStablePtr_RDR, makeStablePtr_RDR, bindIO_RDR ) import Bag ( bagToList ) import List ( partition, nub ) @@ -87,11 +88,12 @@ rnSourceDecls :: [RdrNameHsDecl] -> RnMS ([RenamedHsDecl], FreeVars) rnSourceDecls decls = go emptyFVs [] decls where - -- Fixity decls have been dealt with already; ignore them - go fvs ds' [] = returnRn (ds', fvs) - go fvs ds' (FixD _:ds) = go fvs ds' ds - go fvs ds' (d:ds) = rnDecl d `thenRn` \(d', fvs') -> - go (fvs `plusFV` fvs') (d':ds') ds + -- Fixity and deprecations have been dealt with already; ignore them + go fvs ds' [] = returnRn (ds', fvs) + go fvs ds' (FixD _:ds) = go fvs ds' ds + go fvs ds' (DeprecD _:ds) = go fvs ds' ds + go fvs ds' (d:ds) = rnDecl d `thenRn` \(d', fvs') -> + go (fvs `plusFV` fvs') (d':ds') ds \end{code} @@ -111,9 +113,9 @@ rnDecl (ValD binds) = rnTopBinds binds `thenRn` \ (new_binds, fvs) -> rnDecl (SigD (IfaceSig name ty id_infos loc)) = pushSrcLocRn loc $ - lookupBndrRn name `thenRn` \ name' -> - rnHsPolyType doc_str ty `thenRn` \ (ty',fvs1) -> - mapFvRn rnIdInfo id_infos `thenRn` \ (id_infos', fvs2) -> + mkImportedGlobalFromRdrName name `thenRn` \ name' -> + rnHsType doc_str ty `thenRn` \ (ty',fvs1) -> + mapFvRn rnIdInfo id_infos `thenRn` \ (id_infos', fvs2) -> returnRn (SigD (IfaceSig name' ty' id_infos' loc), fvs1 `plusFV` fvs2) where doc_str = text "the interface signature for" <+> quotes (ppr name) @@ -139,7 +141,7 @@ and then go over it again to rename the tyvars! However, we can also do some scoping checks at the same time. \begin{code} -rnDecl (TyClD (TyData new_or_data context tycon tyvars condecls derivings pragmas src_loc)) +rnDecl (TyClD (TyData new_or_data context tycon tyvars condecls nconstrs derivings pragmas src_loc)) = pushSrcLocRn src_loc $ lookupBndrRn tycon `thenRn` \ tycon' -> bindTyVarsFVRn data_doc tyvars $ \ tyvars' -> @@ -148,7 +150,7 @@ rnDecl (TyClD (TyData new_or_data context tycon tyvars condecls derivings pragma mapFvRn rnConDecl condecls `thenRn` \ (condecls', con_fvs) -> rnDerivs derivings `thenRn` \ (derivings', deriv_fvs) -> ASSERT(isNoDataPragmas pragmas) - returnRn (TyClD (TyData new_or_data context' tycon' tyvars' condecls' + returnRn (TyClD (TyData new_or_data context' tycon' tyvars' condecls' nconstrs derivings' noDataPragmas src_loc), cxt_fvs `plusFV` con_fvs `plusFV` deriv_fvs) where @@ -159,7 +161,7 @@ rnDecl (TyClD (TySynonym name tyvars ty src_loc)) = pushSrcLocRn src_loc $ lookupBndrRn name `thenRn` \ name' -> bindTyVarsFVRn syn_doc tyvars $ \ tyvars' -> - rnHsPolyType syn_doc (unquantify ty) `thenRn` \ (ty', ty_fvs) -> + rnHsType syn_doc (unquantify ty) `thenRn` \ (ty', ty_fvs) -> returnRn (TyClD (TySynonym name' tyvars' ty' src_loc), ty_fvs) where syn_doc = text "the declaration for type synonym" <+> quotes (ppr name) @@ -349,26 +351,23 @@ rnDecl (ForD (ForeignDecl name imp_exp ty ext_nm cconv src_loc)) = pushSrcLocRn src_loc $ lookupOccRn name `thenRn` \ name' -> let - ok_ext_nm Dynamic = True - ok_ext_nm (ExtName nm (Just mb)) = isCLabelString nm && isCLabelString mb - ok_ext_nm (ExtName nm Nothing) = isCLabelString nm - - fvs1 = case imp_exp of - FoImport _ | not isDyn -> emptyFVs - FoLabel -> emptyFVs - FoExport | isDyn -> mkNameSet [makeStablePtr_NAME, - deRefStablePtr_NAME, - bindIO_NAME, returnIO_NAME] - | otherwise -> mkNameSet [name'] - _ -> emptyFVs + extra_fvs FoExport + | isDyn = lookupImplicitOccsRn [makeStablePtr_RDR, deRefStablePtr_RDR, bindIO_RDR] + | otherwise = returnRn (unitFV name') + extra_fvs other = returnRn emptyFVs in checkRn (ok_ext_nm ext_nm) (badExtName ext_nm) `thenRn_` + extra_fvs imp_exp `thenRn` \ fvs1 -> rnHsSigType fo_decl_msg ty `thenRn` \ (ty', fvs2) -> returnRn (ForD (ForeignDecl name' imp_exp ty' ext_nm cconv src_loc), fvs1 `plusFV` fvs2) where fo_decl_msg = ptext SLIT("a foreign declaration") isDyn = isDynamicExtName ext_nm + + ok_ext_nm Dynamic = True + ok_ext_nm (ExtName nm (Just mb)) = isCLabelString nm && isCLabelString mb + ok_ext_nm (ExtName nm Nothing) = isCLabelString nm \end{code} %********************************************************* @@ -378,13 +377,23 @@ rnDecl (ForD (ForeignDecl name imp_exp ty ext_nm cconv src_loc)) %********************************************************* \begin{code} -rnDecl (RuleD (IfaceRuleDecl var body src_loc)) - = pushSrcLocRn src_loc $ - lookupOccRn var `thenRn` \ var' -> - rnRuleBody body `thenRn` \ (body', fvs) -> - returnRn (RuleD (IfaceRuleDecl var' body' src_loc), fvs `addOneFV` var') +rnDecl (RuleD (IfaceRule rule_name vars fn args rhs src_loc)) + = pushSrcLocRn src_loc $ + lookupOccRn fn `thenRn` \ fn' -> + rnCoreBndrs vars $ \ vars' -> + mapFvRn rnCoreExpr args `thenRn` \ (args', fvs1) -> + rnCoreExpr rhs `thenRn` \ (rhs', fvs2) -> + returnRn (RuleD (IfaceRule rule_name vars' fn' args' rhs' src_loc), + (fvs1 `plusFV` fvs2) `addOneFV` fn') -rnDecl (RuleD (RuleDecl rule_name tvs vars lhs rhs src_loc)) +rnDecl (RuleD (IfaceRuleOut fn rule)) + -- This one is used for BuiltInRules + -- The rule itself is already done, but the thing + -- to attach it to is not. + = lookupOccRn fn `thenRn` \ fn' -> + returnRn (RuleD (IfaceRuleOut fn' rule), unitFV fn') + +rnDecl (RuleD (HsRule rule_name tvs vars lhs rhs src_loc)) = ASSERT( null tvs ) pushSrcLocRn src_loc $ @@ -400,7 +409,7 @@ rnDecl (RuleD (RuleDecl rule_name tvs vars lhs rhs src_loc)) bad_vars = [var | var <- ids, not (var `elemNameSet` fv_lhs)] in mapRn (addErrRn . badRuleVar rule_name) bad_vars `thenRn_` - returnRn (RuleD (RuleDecl rule_name sig_tvs' vars' lhs' rhs' src_loc), + returnRn (RuleD (HsRule rule_name sig_tvs' vars' lhs' rhs' src_loc), fv_vars `plusFV` fv_lhs `plusFV` fv_rhs) where doc = text "the transformation rule" <+> ptext rule_name @@ -410,7 +419,7 @@ rnDecl (RuleD (RuleDecl rule_name tvs vars lhs rhs src_loc)) get_var (RuleBndrSig v _) = v rn_var (RuleBndr v, id) = returnRn (RuleBndr id, emptyFVs) - rn_var (RuleBndrSig v t, id) = rnHsPolyType doc t `thenRn` \ (t', fvs) -> + rn_var (RuleBndrSig v t, id) = rnHsType doc t `thenRn` \ (t', fvs) -> returnRn (RuleBndrSig id t', fvs) \end{code} @@ -468,7 +477,7 @@ rnConDetails doc locn (InfixCon ty1 ty2) returnRn (InfixCon new_ty1 new_ty2, fvs1 `plusFV` fvs2) rnConDetails doc locn (NewCon ty mb_field) - = rnHsPolyType doc ty `thenRn` \ (new_ty, fvs) -> + = rnHsType doc ty `thenRn` \ (new_ty, fvs) -> rn_field mb_field `thenRn` \ new_mb_field -> returnRn (NewCon new_ty new_mb_field, fvs) where @@ -490,15 +499,15 @@ rnField doc (names, ty) returnRn ((new_names, new_ty), fvs) rnBangTy doc (Banged ty) - = rnHsPolyType doc ty `thenRn` \ (new_ty, fvs) -> + = rnHsType doc ty `thenRn` \ (new_ty, fvs) -> returnRn (Banged new_ty, fvs) rnBangTy doc (Unbanged ty) - = rnHsPolyType doc ty `thenRn` \ (new_ty, fvs) -> + = rnHsType doc ty `thenRn` \ (new_ty, fvs) -> returnRn (Unbanged new_ty, fvs) rnBangTy doc (Unpacked ty) - = rnHsPolyType doc ty `thenRn` \ (new_ty, fvs) -> + = rnHsType doc ty `thenRn` \ (new_ty, fvs) -> returnRn (Unpacked new_ty, fvs) -- This data decl will parse OK @@ -528,15 +537,12 @@ rnHsSigType :: SDoc -> RdrNameHsType -> RnMS (RenamedHsType, FreeVars) -- rnHsSigType is used for source-language type signatures, -- which use *implicit* universal quantification. rnHsSigType doc_str ty - = rnHsPolyType (text "the type signature for" <+> doc_str) ty + = rnHsType (text "the type signature for" <+> doc_str) ty --------------------------------------- -rnHsPolyType, rnHsType :: SDoc -> RdrNameHsType -> RnMS (RenamedHsType, FreeVars) --- rnHsPolyType is prepared to see a for-all; rnHsType is not --- The former is called for the top level of type sigs and function args. +rnHsType :: SDoc -> RdrNameHsType -> RnMS (RenamedHsType, FreeVars) ---------------------------------------- -rnHsPolyType doc (HsForAllTy Nothing ctxt ty) +rnHsType doc (HsForAllTy Nothing ctxt ty) -- Implicit quantifiction in source code (no kinds on tyvars) -- Given the signature C => T we universally quantify -- over FV(T) \ {in-scope-tyvars} @@ -548,7 +554,7 @@ rnHsPolyType doc (HsForAllTy Nothing ctxt ty) checkConstraints doc forall_tyvars mentioned_in_tau ctxt ty `thenRn` \ ctxt' -> rnForAll doc (map UserTyVar forall_tyvars) ctxt' ty -rnHsPolyType doc (HsForAllTy (Just forall_tyvars) ctxt tau) +rnHsType doc (HsForAllTy (Just forall_tyvars) ctxt tau) -- Explicit quantification. -- Check that the forall'd tyvars are a subset of the -- free tyvars in the tau-type part @@ -576,9 +582,79 @@ rnHsPolyType doc (HsForAllTy (Just forall_tyvars) ctxt tau) checkConstraints doc forall_tyvar_names mentioned_in_tau ctxt tau `thenRn` \ ctxt' -> rnForAll doc forall_tyvars ctxt' tau -rnHsPolyType doc other_ty = rnHsType doc other_ty +rnHsType doc (HsTyVar tyvar) + = lookupOccRn tyvar `thenRn` \ tyvar' -> + returnRn (HsTyVar tyvar', unitFV tyvar') + +rnHsType doc (HsFunTy ty1 ty2) + = rnHsType doc ty1 `thenRn` \ (ty1', fvs1) -> + -- Might find a for-all as the arg of a function type + rnHsType doc ty2 `thenRn` \ (ty2', fvs2) -> + -- Or as the result. This happens when reading Prelude.hi + -- when we find return :: forall m. Monad m -> forall a. a -> m a + returnRn (HsFunTy ty1' ty2', fvs1 `plusFV` fvs2) +rnHsType doc (HsListTy ty) + = rnHsType doc ty `thenRn` \ (ty', fvs) -> + returnRn (HsListTy ty', fvs `addOneFV` listTyCon_name) +-- Unboxed tuples are allowed to have poly-typed arguments. These +-- sometimes crop up as a result of CPR worker-wrappering dictionaries. +rnHsType doc (HsTupleTy (HsTupCon _ boxity) tys) + -- Don't do lookupOccRn, because this is built-in syntax + -- so it doesn't need to be in scope + = mapFvRn (rnHsType doc) tys `thenRn` \ (tys', fvs) -> + returnRn (HsTupleTy (HsTupCon n' boxity) tys', fvs `addOneFV` n') + where + n' = tupleTyCon_name boxity (length tys) + + +rnHsType doc (HsAppTy ty1 ty2) + = rnHsType doc ty1 `thenRn` \ (ty1', fvs1) -> + rnHsType doc ty2 `thenRn` \ (ty2', fvs2) -> + returnRn (HsAppTy ty1' ty2', fvs1 `plusFV` fvs2) + +rnHsType doc (HsPredTy pred) + = rnPred doc pred `thenRn` \ (pred', fvs) -> + returnRn (HsPredTy pred', fvs) + +rnHsType doc (HsUsgForAllTy uv_rdr ty) + = bindUVarRn doc uv_rdr $ \ uv_name -> + rnHsType doc ty `thenRn` \ (ty', fvs) -> + returnRn (HsUsgForAllTy uv_name ty', + fvs ) + +rnHsType doc (HsUsgTy usg ty) + = newUsg usg `thenRn` \ (usg', usg_fvs) -> + rnHsType doc ty `thenRn` \ (ty', ty_fvs) -> + -- A for-all can occur inside a usage annotation + returnRn (HsUsgTy usg' ty', + usg_fvs `plusFV` ty_fvs) + where + newUsg usg = case usg of + HsUsOnce -> returnRn (HsUsOnce, emptyFVs) + HsUsMany -> returnRn (HsUsMany, emptyFVs) + HsUsVar uv_rdr -> lookupOccRn uv_rdr `thenRn` \ uv_name -> + returnRn (HsUsVar uv_name, emptyFVs) + +rnHsTypes doc tys = mapFvRn (rnHsType doc) tys +\end{code} + +\begin{code} +-- We use lookupOcc here because this is interface file only stuff +-- and we need the workers... +rnHsTupCon (HsTupCon n boxity) + = lookupOccRn n `thenRn` \ n' -> + returnRn (HsTupCon n' boxity, unitFV n') + +rnHsTupConWkr (HsTupCon n boxity) + -- Tuple construtors are for the *worker* of the tuple + -- Going direct saves needless messing about + = lookupOccRn (mkRdrNameWkr n) `thenRn` \ n' -> + returnRn (HsTupCon n' boxity, unitFV n') +\end{code} + +\begin{code} -- Check that each constraint mentions at least one of the forall'd type variables -- Since the forall'd type variables are a subset of the free tyvars -- of the tau-type part, this guarantees that every constraint mentions @@ -605,94 +681,40 @@ rnForAll doc forall_tyvars ctxt ty rnHsType doc ty `thenRn` \ (new_ty, ty_fvs) -> returnRn (mkHsForAllTy (Just new_tyvars) new_ctxt new_ty, cxt_fvs `plusFV` ty_fvs) - ---------------------------------------- -rnHsType doc ty@(HsForAllTy _ _ inner_ty) - = addWarnRn (unexpectedForAllTy ty) `thenRn_` - rnHsPolyType doc ty - -rnHsType doc (MonoTyVar tyvar) - = lookupOccRn tyvar `thenRn` \ tyvar' -> - returnRn (MonoTyVar tyvar', unitFV tyvar') - -rnHsType doc (MonoFunTy ty1 ty2) - = rnHsPolyType doc ty1 `thenRn` \ (ty1', fvs1) -> - -- Might find a for-all as the arg of a function type - rnHsPolyType doc ty2 `thenRn` \ (ty2', fvs2) -> - -- Or as the result. This happens when reading Prelude.hi - -- when we find return :: forall m. Monad m -> forall a. a -> m a - returnRn (MonoFunTy ty1' ty2', fvs1 `plusFV` fvs2) - -rnHsType doc (MonoListTy ty) - = rnHsType doc ty `thenRn` \ (ty', fvs) -> - returnRn (MonoListTy ty', fvs `addOneFV` listTyCon_name) - --- Unboxed tuples are allowed to have poly-typed arguments. These --- sometimes crop up as a result of CPR worker-wrappering dictionaries. -rnHsType doc (MonoTupleTy tys boxed) - = (if boxed - then mapFvRn (rnHsType doc) tys - else mapFvRn (rnHsPolyType doc) tys) `thenRn` \ (tys', fvs) -> - returnRn (MonoTupleTy tys' boxed, fvs `addOneFV` tup_con_name) - where - tup_con_name = tupleTyCon_name boxed (length tys) - -rnHsType doc (MonoTyApp ty1 ty2) - = rnHsType doc ty1 `thenRn` \ (ty1', fvs1) -> - rnHsType doc ty2 `thenRn` \ (ty2', fvs2) -> - returnRn (MonoTyApp ty1' ty2', fvs1 `plusFV` fvs2) - -rnHsType doc (MonoIParamTy n ty) - = getIPName n `thenRn` \ name -> - rnHsType doc ty `thenRn` \ (ty', fvs) -> - returnRn (MonoIParamTy name ty', fvs) - -rnHsType doc (MonoDictTy clas tys) - = lookupOccRn clas `thenRn` \ clas' -> - rnHsTypes doc tys `thenRn` \ (tys', fvs) -> - returnRn (MonoDictTy clas' tys', fvs `addOneFV` clas') - -rnHsType doc (MonoUsgForAllTy uv_rdr ty) - = bindUVarRn doc uv_rdr $ \ uv_name -> - rnHsType doc ty `thenRn` \ (ty', fvs) -> - returnRn (MonoUsgForAllTy uv_name ty', - fvs ) - -rnHsType doc (MonoUsgTy usg ty) - = newUsg usg `thenRn` \ (usg', usg_fvs) -> - rnHsPolyType doc ty `thenRn` \ (ty', ty_fvs) -> - -- A for-all can occur inside a usage annotation - returnRn (MonoUsgTy usg' ty', - usg_fvs `plusFV` ty_fvs) - where - newUsg usg = case usg of - MonoUsOnce -> returnRn (MonoUsOnce, emptyFVs) - MonoUsMany -> returnRn (MonoUsMany, emptyFVs) - MonoUsVar uv_rdr -> lookupOccRn uv_rdr `thenRn` \ uv_name -> - returnRn (MonoUsVar uv_name, emptyFVs) - -rnHsTypes doc tys = mapFvRn (rnHsType doc) tys \end{code} - \begin{code} rnContext :: SDoc -> RdrNameContext -> RnMS (RenamedContext, FreeVars) - rnContext doc ctxt - = mapAndUnzipRn (rnPred doc) ctxt `thenRn` \ (theta, fvs_s) -> + = mapAndUnzipRn rn_pred ctxt `thenRn` \ (theta, fvs_s) -> let - (_, dup_asserts) = removeDups (cmpHsPred compare) theta + (_, dups) = removeDupsEq theta + -- We only have equality, not ordering in -- Check for duplicate assertions -- If this isn't an error, then it ought to be: - mapRn_ (addWarnRn . dupClassAssertWarn theta) dup_asserts `thenRn_` - + mapRn (addWarnRn . dupClassAssertWarn theta) dups `thenRn_` returnRn (theta, plusFVs fvs_s) + where + --Someone discovered that @CCallable@ and @CReturnable@ + -- could be used in contexts such as: + -- foo :: CCallable a => a -> PrimIO Int + -- Doing this utterly wrecks the whole point of introducing these + -- classes so we specifically check that this isn't being done. + rn_pred pred = rnPred doc pred `thenRn` \ (pred', fvs)-> + checkRn (not (bad_pred pred')) + (naughtyCCallContextErr pred') `thenRn_` + returnRn (pred', fvs) + + bad_pred (HsPClass clas _) = getUnique clas `elem` cCallishClassKeys + bad_pred other = False + rnPred doc (HsPClass clas tys) = lookupOccRn clas `thenRn` \ clas_name -> rnHsTypes doc tys `thenRn` \ (tys', fvs) -> returnRn (HsPClass clas_name tys', fvs `addOneFV` clas_name) + rnPred doc (HsPIParam n ty) = getIPName n `thenRn` \ name -> rnHsType doc ty `thenRn` \ (ty', fvs) -> @@ -700,7 +722,7 @@ rnPred doc (HsPIParam n ty) \end{code} \begin{code} -rnFds :: SDoc -> [([RdrName],[RdrName])] -> RnMS ([([Name],[Name])], FreeVars) +rnFds :: SDoc -> [FunDep RdrName] -> RnMS ([FunDep Name], FreeVars) rnFds doc fds = mapAndUnzipRn rn_fds fds `thenRn` \ (theta, fvs_s) -> @@ -736,22 +758,14 @@ rnIdInfo (HsArity arity) = returnRn (HsArity arity, emptyFVs) rnIdInfo (HsUpdate update) = returnRn (HsUpdate update, emptyFVs) rnIdInfo HsNoCafRefs = returnRn (HsNoCafRefs, emptyFVs) rnIdInfo HsCprInfo = returnRn (HsCprInfo, emptyFVs) -rnIdInfo (HsSpecialise rule_body) = rnRuleBody rule_body - `thenRn` \ (rule_body', fvs) -> - returnRn (HsSpecialise rule_body', fvs) -rnRuleBody (UfRuleBody str vars args rhs) - = rnCoreBndrs vars $ \ vars' -> - mapFvRn rnCoreExpr args `thenRn` \ (args', fvs1) -> - rnCoreExpr rhs `thenRn` \ (rhs', fvs2) -> - returnRn (UfRuleBody str vars' args' rhs', fvs1 `plusFV` fvs2) \end{code} @UfCore@ expressions. \begin{code} rnCoreExpr (UfType ty) - = rnHsPolyType (text "unfolding type") ty `thenRn` \ (ty', fvs) -> + = rnHsType (text "unfolding type") ty `thenRn` \ (ty', fvs) -> returnRn (UfType ty', fvs) rnCoreExpr (UfVar v) @@ -766,13 +780,13 @@ rnCoreExpr (UfLitLit l ty) returnRn (UfLitLit l ty', fvs) rnCoreExpr (UfCCall cc ty) - = rnHsPolyType (text "ccall") ty `thenRn` \ (ty', fvs) -> + = rnHsType (text "ccall") ty `thenRn` \ (ty', fvs) -> returnRn (UfCCall cc ty', fvs) rnCoreExpr (UfTuple con args) - = lookupOccRn con `thenRn` \ con' -> - mapFvRn rnCoreExpr args `thenRn` \ (args', fvs) -> - returnRn (UfTuple con' args', fvs `addOneFV` con') + = rnHsTupConWkr con `thenRn` \ (con', fvs1) -> + mapFvRn rnCoreExpr args `thenRn` \ (args', fvs2) -> + returnRn (UfTuple con' args', fvs1 `plusFV` fvs2) rnCoreExpr (UfApp fun arg) = rnCoreExpr fun `thenRn` \ (fun', fv1) -> @@ -816,7 +830,7 @@ rnCoreExpr (UfLet (UfRec pairs) body) \begin{code} rnCoreBndr (UfValBinder name ty) thing_inside - = rnHsPolyType doc ty `thenRn` \ (ty', fvs1) -> + = rnHsType doc ty `thenRn` \ (ty', fvs1) -> bindCoreLocalFVRn name ( \ name' -> thing_inside (UfValBinder name' ty') ) `thenRn` \ (result, fvs2) -> @@ -836,7 +850,7 @@ rnCoreBndrs (b:bs) thing_inside = rnCoreBndr b $ \ name' -> \begin{code} rnCoreAlt (con, bndrs, rhs) - = rnUfCon con `thenRn` \ (con', fvs1) -> + = rnUfCon con bndrs `thenRn` \ (con', fvs1) -> bindCoreLocalsFVRn bndrs ( \ bndrs' -> rnCoreExpr rhs `thenRn` \ (rhs', fvs2) -> returnRn ((con', bndrs', rhs'), fvs2) @@ -844,7 +858,7 @@ rnCoreAlt (con, bndrs, rhs) returnRn (result, fvs1 `plusFV` fvs3) rnNote (UfCoerce ty) - = rnHsPolyType (text "unfolding coerce") ty `thenRn` \ (ty', fvs) -> + = rnHsType (text "unfolding coerce") ty `thenRn` \ (ty', fvs) -> returnRn (UfCoerce ty', fvs) rnNote (UfSCC cc) = returnRn (UfSCC cc, emptyFVs) @@ -852,18 +866,23 @@ rnNote UfInlineCall = returnRn (UfInlineCall, emptyFVs) rnNote UfInlineMe = returnRn (UfInlineMe, emptyFVs) -rnUfCon UfDefault +rnUfCon UfDefault _ = returnRn (UfDefault, emptyFVs) -rnUfCon (UfDataAlt con) +rnUfCon (UfTupleAlt tup_con) bndrs + = rnHsTupCon tup_con `thenRn` \ (HsTupCon con' _, fvs) -> + returnRn (UfDataAlt con', fvs) + -- Makes the type checker a little easier + +rnUfCon (UfDataAlt con) _ = lookupOccRn con `thenRn` \ con' -> returnRn (UfDataAlt con', unitFV con') -rnUfCon (UfLitAlt lit) +rnUfCon (UfLitAlt lit) _ = returnRn (UfLitAlt lit, emptyFVs) -rnUfCon (UfLitLitAlt lit ty) - = rnHsPolyType (text "litlit") ty `thenRn` \ (ty', fvs) -> +rnUfCon (UfLitLitAlt lit ty) _ + = rnHsType (text "litlit") ty `thenRn` \ (ty', fvs) -> returnRn (UfLitLitAlt lit ty', fvs) \end{code} @@ -903,12 +922,6 @@ classTyVarNotInOpTyErr clas_tyvar sig ptext SLIT("does not appear in method signature")]) 4 (ppr sig) -dupClassAssertWarn ctxt (assertion : dups) - = sep [hsep [ptext SLIT("Duplicate class assertion"), - quotes (pprHsPred assertion), - ptext SLIT("in the context:")], - nest 4 (pprHsContext ctxt <+> ptext SLIT("..."))] - badDataCon name = hsep [ptext SLIT("Illegal data constructor name"), quotes (ppr name)] @@ -940,7 +953,7 @@ forAllErr doc ty tyvar univErr doc constraint ty = sep [ptext SLIT("All of the type variable(s) in the constraint") - <+> quotes (pprHsPred constraint) + <+> quotes (ppr constraint) <+> ptext SLIT("are already in scope"), nest 4 (ptext SLIT("At least one must be universally quantified here")) ] @@ -948,15 +961,12 @@ univErr doc constraint ty (ptext SLIT("In") <+> doc) ambigErr doc constraint ty - = sep [ptext SLIT("Ambiguous constraint") <+> quotes (pprHsPred constraint), + = sep [ptext SLIT("Ambiguous constraint") <+> quotes (ppr constraint), nest 4 (ptext SLIT("in the type:") <+> ppr ty), nest 4 (ptext SLIT("Each forall-d type variable mentioned by the constraint must appear after the =>."))] $$ (ptext SLIT("In") <+> doc) -unexpectedForAllTy ty - = ptext SLIT("Unexpected forall type:") <+> ppr ty - badRuleLhsErr name lhs = sep [ptext SLIT("Rule") <+> ptext name <> colon, nest 4 (ptext SLIT("Illegal left-hand side:") <+> ppr lhs)] @@ -971,4 +981,14 @@ badRuleVar name var badExtName :: ExtName -> Message badExtName ext_nm = sep [quotes (ppr ext_nm) <+> ptext SLIT("is not a valid C identifier")] + +dupClassAssertWarn ctxt (assertion : dups) + = sep [hsep [ptext SLIT("Duplicate class assertion"), + quotes (ppr assertion), + ptext SLIT("in the context:")], + nest 4 (ppr ctxt <+> ptext SLIT("..."))] + +naughtyCCallContextErr (HsPClass clas _) + = sep [ptext SLIT("Can't use class") <+> quotes (ppr clas), + ptext SLIT("in a context")] \end{code} diff --git a/ghc/compiler/simplCore/OccurAnal.lhs b/ghc/compiler/simplCore/OccurAnal.lhs index 2aefb2b0e7..ef5ce99979 100644 --- a/ghc/compiler/simplCore/OccurAnal.lhs +++ b/ghc/compiler/simplCore/OccurAnal.lhs @@ -12,9 +12,7 @@ core expression with (hopefully) improved usage information. \begin{code} module OccurAnal ( - occurAnalyseBinds, occurAnalyseExpr, occurAnalyseGlobalExpr, - markBinderInsideLambda, tagBinders, - UsageDetails + occurAnalyseBinds, occurAnalyseGlobalExpr, occurAnalyseRule ) where #include "HsVersions.h" @@ -42,7 +40,7 @@ import Maybes ( maybeToBool ) import Digraph ( stronglyConnCompR, SCC(..) ) import Unique ( u2i, buildIdKey, foldrIdKey, runSTRepIdKey, augmentIdKey ) import UniqFM ( keysUFM ) -import Util ( zipWithEqual, mapAndUnzip, count ) +import Util ( zipWithEqual, mapAndUnzip ) import Outputable \end{code} @@ -71,6 +69,15 @@ occurAnalyseGlobalExpr expr = -- Top level expr, so no interesting free vars, and -- discard occurence info returned snd (occurAnalyseExpr (\_ -> False) expr) + +occurAnalyseRule :: CoreRule -> CoreRule +occurAnalyseRule rule@(BuiltinRule _) = rule +occurAnalyseRule (Rule str tpl_vars tpl_args rhs) + -- Add occ info to tpl_vars, rhs + = Rule str tpl_vars' tpl_args rhs' + where + (rhs_uds, rhs') = occurAnalyseExpr isLocallyDefined rhs + (rhs_uds1, tpl_vars') = tagBinders rhs_uds tpl_vars \end{code} @@ -853,15 +860,5 @@ setBinderOcc usage bndr Nothing -> IAmDead Just info -> binderInfoToOccInfo info -markBinderInsideLambda :: CoreBndr -> CoreBndr -markBinderInsideLambda bndr - | isTyVar bndr - = bndr - - | otherwise - = case idOccInfo bndr of - OneOcc _ once -> bndr `setIdOccInfo` OneOcc insideLam once - other -> bndr - funOccZero = funOccurrence 0 \end{code} diff --git a/ghc/compiler/simplCore/SetLevels.lhs b/ghc/compiler/simplCore/SetLevels.lhs index 82ab025131..22472899d0 100644 --- a/ghc/compiler/simplCore/SetLevels.lhs +++ b/ghc/compiler/simplCore/SetLevels.lhs @@ -44,21 +44,19 @@ import CoreSyn import CoreUtils ( exprType, exprIsTrivial, exprIsBottom ) import CoreFVs -- all of it +import Subst import Id ( Id, idType, idFreeTyVars, mkSysLocal, isOneShotLambda, modifyIdInfo, idSpecialisation, idWorkerInfo, setIdInfo ) import IdInfo ( workerExists, vanillaIdInfo, demandInfo, setDemandInfo ) import Var ( Var, TyVar, setVarUnique ) -import VarEnv -import Subst import VarSet +import VarEnv import Name ( getOccName ) import OccName ( occNameUserString ) import Type ( isUnLiftedType, mkPiType, Type ) import BasicTypes ( TopLevelFlag(..) ) import Demand ( isStrict, wwLazy ) -import VarSet -import VarEnv import UniqSupply import Util ( sortLt, isSingleton, count ) import Outputable @@ -674,7 +672,8 @@ cloneVar :: TopLevelFlag -> LevelEnv -> Id -> Level -> Level -> LvlM (LevelEnv, cloneVar TopLevel env v ctxt_lvl dest_lvl = returnUs (env, v) -- Don't clone top level things cloneVar NotTopLevel env v ctxt_lvl dest_lvl - = getUniqueUs `thenLvl` \ uniq -> + = ASSERT( isId v ) + getUniqueUs `thenLvl` \ uniq -> let v' = setVarUnique v uniq v'' = subst_id_info env ctxt_lvl dest_lvl v' @@ -686,7 +685,8 @@ cloneVars :: TopLevelFlag -> LevelEnv -> [Id] -> Level -> Level -> LvlM (LevelEn cloneVars TopLevel env vs ctxt_lvl dest_lvl = returnUs (env, vs) -- Don't clone top level things cloneVars NotTopLevel env vs ctxt_lvl dest_lvl - = getUniquesUs (length vs) `thenLvl` \ uniqs -> + = ASSERT( all isId vs ) + getUniquesUs (length vs) `thenLvl` \ uniqs -> let vs' = zipWith setVarUnique vs uniqs vs'' = map (subst_id_info env' ctxt_lvl dest_lvl) vs' diff --git a/ghc/compiler/simplCore/SimplCore.lhs b/ghc/compiler/simplCore/SimplCore.lhs index 754f7deb06..4d2d4fda98 100644 --- a/ghc/compiler/simplCore/SimplCore.lhs +++ b/ghc/compiler/simplCore/SimplCore.lhs @@ -44,7 +44,6 @@ import Name ( mkLocalName, tidyOccName, tidyTopName, NamedThing(..), OccName ) import TyCon ( TyCon, isDataTyCon ) -import PrelRules ( builtinRules ) import Type ( Type, isUnLiftedType, tidyType, tidyTypes, tidyTopType, tidyTyVar, tidyTyVars, @@ -94,11 +93,8 @@ core2core core_todos binds rules better_local_rules <- simplRules ru_us local_rules binds - let all_imported_rules = builtinRules ++ imported_rules - -- Here is where we add in the built-in rules - let (binds1, local_rule_base) = prepareLocalRuleBase binds better_local_rules - imported_rule_base = prepareOrphanRuleBase all_imported_rules + imported_rule_base = prepareOrphanRuleBase imported_rules -- Do the main business (stats, processed_binds, processed_local_rules) @@ -205,6 +201,8 @@ simplRules us rules binds bind_vars = foldr (unionVarSet . mkVarSet . bindersOf) emptyVarSet binds +simplRule rule@(ProtoCoreRule is_local id (BuiltinRule _)) + = returnSmpl rule simplRule rule@(ProtoCoreRule is_local id (Rule name bndrs args rhs)) | not is_local = returnSmpl rule -- No need to fiddle with imported rules diff --git a/ghc/compiler/simplCore/SimplUtils.lhs b/ghc/compiler/simplCore/SimplUtils.lhs index f09d6aeb0a..34ee7d6115 100644 --- a/ghc/compiler/simplCore/SimplUtils.lhs +++ b/ghc/compiler/simplCore/SimplUtils.lhs @@ -35,8 +35,9 @@ import Maybes ( maybeToBool, catMaybes ) import Name ( isLocalName, setNameUnique ) import SimplMonad import Type ( Type, tyVarsOfType, tyVarsOfTypes, mkForAllTys, seqType, repType, - splitTyConApp_maybe, splitAlgTyConApp_maybe, mkTyVarTys, applyTys, splitFunTys, mkFunTys + splitTyConApp_maybe, mkTyVarTys, applyTys, splitFunTys, mkFunTys ) +import TyCon ( tyConDataConsIfAvailable ) import PprType ( {- instance Outputable Type -} ) import DataCon ( dataConRepArity ) import TysPrim ( statePrimTyCon ) @@ -288,11 +289,16 @@ discardInline cont = cont -- Note the repType: we want to look through newtypes for this purpose -canUpdateInPlace ty = case splitAlgTyConApp_maybe (repType ty) of - Just (_, _, [dc]) -> arity == 1 || arity == 2 - where - arity = dataConRepArity dc +canUpdateInPlace ty = case splitTyConApp_maybe (repType ty) of { + Nothing -> False ; + Just (tycon, _) -> + + case tyConDataConsIfAvailable tycon of + [dc] -> arity == 1 || arity == 2 + where + arity = dataConRepArity dc other -> False + } \end{code} diff --git a/ghc/compiler/simplCore/Simplify.lhs b/ghc/compiler/simplCore/Simplify.lhs index 92bb34c850..24eea0f25d 100644 --- a/ghc/compiler/simplCore/Simplify.lhs +++ b/ghc/compiler/simplCore/Simplify.lhs @@ -30,7 +30,7 @@ import Id ( Id, idType, idInfo, idUnique, isDataConId, isDataConId_maybe, idOccInfo, setIdOccInfo, zapLamIdInfo, zapFragileIdInfo, idStrictness, isBottomingId, - setInlinePragma, mayHaveNoBinding, + setInlinePragma, setOneShotLambda, maybeModifyIdInfo ) import IdInfo ( InlinePragInfo(..), OccInfo(..), StrictnessInfo(..), @@ -42,9 +42,8 @@ import Demand ( Demand, isStrict, wwLazy ) import DataCon ( DataCon, dataConNumInstArgs, dataConRepStrictness, dataConRepArity, dataConSig, dataConArgTys ) -import Name ( isLocallyDefined ) import CoreSyn -import CoreFVs ( exprFreeVars ) +import CoreFVs ( exprFreeVars, mustHaveLocalBinding ) import CoreUnfold ( Unfolding, mkOtherCon, mkUnfolding, otherCons, maybeUnfoldingTemplate, callSiteInline, hasSomeUnfolding, noUnfolding ) @@ -63,7 +62,9 @@ import Type ( Type, mkTyVarTy, mkTyVarTys, isUnLiftedType, seqType, import Subst ( Subst, mkSubst, emptySubst, substTy, substExpr, substEnv, isInScope, lookupIdSubst, substIdInfo ) -import TyCon ( isDataTyCon, tyConDataCons, tyConClass_maybe, tyConArity, isDataTyCon ) +import TyCon ( isDataTyCon, tyConDataConsIfAvailable, + tyConClass_maybe, tyConArity, isDataTyCon + ) import TysPrim ( realWorldStatePrimTy ) import PrelInfo ( realWorldPrimId ) import BasicTypes ( TopLevelFlag(..), isTopLevel, isLoopBreaker ) @@ -732,11 +733,8 @@ simplVar var cont case lookupIdSubst subst var of DoneEx e -> zapSubstEnv (simplExprF e cont) ContEx env1 e -> setSubstEnv env1 (simplExprF e cont) - DoneId var1 occ -> WARN( not (isInScope var1 subst) && isLocallyDefined var1 && not (mayHaveNoBinding var1), + DoneId var1 occ -> WARN( not (isInScope var1 subst) && mustHaveLocalBinding var1, text "simplVar:" <+> ppr var ) - -- The mayHaveNoBinding test accouunts for the fact - -- that class dictionary constructors dont have top level - -- bindings and hence aren't in scope. zapSubstEnv (completeCall var1 occ cont) -- The template is already simplified, so don't re-substitute. -- This is VITAL. Consider @@ -1358,7 +1356,7 @@ prepareCaseAlts bndr (Just (tycon, inst_tys)) scrut_cons alts [] -> alts other -> [alt | alt@(con,_,_) <- alts, not (con `elem` scrut_cons)] - missing_cons = [data_con | data_con <- tyConDataCons tycon, + missing_cons = [data_con | data_con <- tyConDataConsIfAvailable tycon, not (data_con `elem` handled_data_cons)] handled_data_cons = [data_con | DataAlt data_con <- scrut_cons] ++ [data_con | (DataAlt data_con, _, _) <- filtered_alts] diff --git a/ghc/compiler/specialise/Rules.lhs b/ghc/compiler/specialise/Rules.lhs index 9d77aaf56b..6e7c6c233d 100644 --- a/ghc/compiler/specialise/Rules.lhs +++ b/ghc/compiler/specialise/Rules.lhs @@ -14,11 +14,11 @@ module Rules ( #include "HsVersions.h" import CoreSyn -- All of it -import OccurAnal ( occurAnalyseExpr, tagBinders, UsageDetails ) +import OccurAnal ( occurAnalyseRule ) import BinderInfo ( markMany ) -import CoreFVs ( exprFreeVars, idRuleVars, ruleSomeLhsFreeVars ) +import CoreFVs ( exprFreeVars, idRuleVars, ruleRhsFreeVars, ruleSomeLhsFreeVars ) import CoreUnfold ( isCheapUnfolding, unfoldingTemplate ) -import CoreUtils ( eqExpr, cheapEqExpr ) +import CoreUtils ( eqExpr ) import PprCore ( pprCoreRule ) import Subst ( Subst, InScopeSet, substBndr, lookupSubst, extendSubst, mkSubst, substEnv, setSubstEnv, emptySubst, isInScope, @@ -28,7 +28,6 @@ import Id ( Id, idUnfolding, zapLamIdInfo, idSpecialisation, setIdSpecialisation, setIdNoDiscard, maybeModifyIdInfo, modifyIdInfo ) -import IdInfo ( setSpecInfo, specInfo ) import Name ( Name, isLocallyDefined ) import Var ( isTyVar, isId ) import VarSet @@ -407,32 +406,30 @@ addRule id (Rules rules rhs_fvs) rule@(BuiltinRule _) = Rules (rule:rules) rhs_fvs -- Put it at the start for lack of anything better -addRule id (Rules rules rhs_fvs) (Rule str tpl_vars tpl_args rhs) - = Rules (insert rules) (rhs_fvs `unionVarSet` new_rhs_fvs) +addRule id (Rules rules rhs_fvs) rule + = Rules (insertRule rules new_rule) (rhs_fvs `unionVarSet` new_rhs_fvs) where - new_rule = Rule str tpl_vars' tpl_args rhs' - -- Add occ info to tpl_vars, rhs - - (rhs_uds, rhs') = occurAnalyseExpr isLocallyDefined rhs - (rhs_uds1, tpl_vars') = tagBinders rhs_uds tpl_vars - - insert [] = [new_rule] - insert (rule:rules) | new_is_more_specific rule = (new_rule:rule:rules) - | otherwise = rule : insert rules - - new_is_more_specific rule = maybeToBool (matchRule tpl_var_set rule tpl_args) - - tpl_var_set = mkVarSet tpl_vars' - -- Actually we should probably include the free vars of tpl_args, - -- but I can't be bothered - - new_rhs_fvs = (exprFreeVars rhs' `minusVarSet` tpl_var_set) `delVarSet` id + new_rule = occurAnalyseRule rule + new_rhs_fvs = ruleRhsFreeVars new_rule `delVarSet` id -- Hack alert! -- Don't include the Id in its own rhs free-var set. -- Otherwise the occurrence analyser makes bindings recursive -- that shoudn't be. E.g. -- RULE: f (f x y) z ==> f x (f y z) +insertRule rules new_rule@(Rule _ tpl_vars tpl_args _) + = go rules + where + tpl_var_set = mkVarSet tpl_vars + -- Actually we should probably include the free vars of tpl_args, + -- but I can't be bothered + + go [] = [new_rule] + go (rule:rules) | new_is_more_specific rule = (new_rule:rule:rules) + | otherwise = rule : go rules + + new_is_more_specific rule = maybeToBool (matchRule tpl_var_set rule tpl_args) + addIdSpecialisations :: Id -> [([CoreBndr], [CoreExpr], CoreExpr)] -> Id addIdSpecialisations id spec_stuff = setIdSpecialisation id new_rules @@ -457,7 +454,7 @@ data ProtoCoreRule CoreRule -- The rule itself -pprProtoCoreRule (ProtoCoreRule _ fn rule) = pprCoreRule (Just fn) rule +pprProtoCoreRule (ProtoCoreRule _ fn rule) = pprCoreRule (ppr fn) rule lookupRule :: InScopeSet -> Id -> [CoreExpr] -> Maybe (RuleName, CoreExpr) lookupRule in_scope fn args diff --git a/ghc/compiler/specialise/Specialise.lhs b/ghc/compiler/specialise/Specialise.lhs index 24a8b619cc..ccf1cee496 100644 --- a/ghc/compiler/specialise/Specialise.lhs +++ b/ghc/compiler/specialise/Specialise.lhs @@ -22,7 +22,7 @@ import Type ( Type, mkTyVarTy, splitSigmaTy, splitFunTysN, mkForAllTys, boxedTypeKind ) import PprType ( {- instance Outputable Type -} ) -import Subst ( Subst, mkSubst, substTy, emptySubst, substBndrs, extendSubstList, +import Subst ( Subst, mkSubst, substTy, mkSubst, substBndrs, extendSubstList, substId, substAndCloneId, substAndCloneIds, lookupIdSubst ) import Var ( TyVar, mkSysTyVar, setVarUnique ) @@ -595,9 +595,16 @@ specProgram us binds return binds' where + -- We need to start with a Subst that knows all the things + -- that are in scope, so that the substitution engine doesn't + -- accidentally re-use a unique that's already in use + -- Easiest thing is to do it all at once, as if all the top-level + -- decls were mutually recursive + top_subst = mkSubst (mkVarSet (bindersOfBinds binds)) emptySubstEnv + go [] = returnSM ([], emptyUDs) go (bind:binds) = go binds `thenSM` \ (binds', uds) -> - specBind emptySubst bind uds `thenSM` \ (bind', uds') -> + specBind top_subst bind uds `thenSM` \ (bind', uds') -> returnSM (bind' ++ binds', uds') dump_specs var = pprCoreRules var (idSpecialisation var) @@ -664,6 +671,7 @@ specExpr subst (Case scrut case_bndr alts) returnSM (Case scrut' case_bndr' alts', uds_scrut `plusUDs` uds_alts) where (subst_alt, case_bndr') = substId subst case_bndr + -- No need to clone case binder; it can't float like a let(rec) spec_alt (con, args, rhs) = specExpr subst_rhs rhs `thenSM` \ (rhs', uds) -> diff --git a/ghc/compiler/stranal/SaAbsInt.lhs b/ghc/compiler/stranal/SaAbsInt.lhs index bec1d11fcd..32b3469993 100644 --- a/ghc/compiler/stranal/SaAbsInt.lhs +++ b/ghc/compiler/stranal/SaAbsInt.lhs @@ -21,12 +21,13 @@ import CoreUnfold ( Unfolding, maybeUnfoldingTemplate ) import Id ( Id, idType, idArity, idStrictness, idUnfolding, isDataConId_maybe ) import DataCon ( dataConTyCon, splitProductType_maybe, dataConRepArgTys ) import IdInfo ( StrictnessInfo(..) ) -import Demand ( Demand(..), wwPrim, wwStrict, wwEnum, wwUnpackData, wwLazy, - wwUnpackNew ) +import Demand ( Demand(..), wwPrim, wwStrict, wwEnum, wwUnpackData, wwLazy, wwUnpackNew, + mkStrictnessInfo, isLazy + ) import SaLib import TyCon ( isProductTyCon, isRecursiveTyCon, isEnumerationTyCon, isNewTyCon ) import BasicTypes ( Arity, NewOrData(..) ) -import Type ( splitAlgTyConApp_maybe, +import Type ( splitTyConApp_maybe, isUnLiftedType, Type ) import TyCon ( tyConUnique ) import PrelInfo ( numericTyKeys ) @@ -602,7 +603,7 @@ findStrictness id (AbsApproxFun str_ds str_res) (AbsApproxFun abs_ds _) -- HOWEVER, if we make diverging functions appear lazy, they -- don't get wrappers, and then we get dreadful reboxing. -- See notes with WwLib.worthSplitting - = StrictnessInfo (combineDemands id str_ds abs_ds) (isBot str_res) + = find_strictness id str_ds str_res abs_ds findStrictness id str_val abs_val = NoStrictnessInfo @@ -616,14 +617,20 @@ findStrictness id str_val abs_val = NoStrictnessInfo -- Here the strictness value takes three args, but the absence value -- takes only one, for reasons I don't quite understand (see cheapFixpoint) -combineDemands id orig_str_ds orig_abs_ds - = go orig_str_ds orig_abs_ds +find_strictness id orig_str_ds orig_str_res orig_abs_ds + = mkStrictnessInfo (go orig_str_ds orig_abs_ds, res_bot) where + res_bot = isBot orig_str_res + go str_ds abs_ds = zipWith mk_dmd str_ds (abs_ds ++ repeat wwLazy) - mk_dmd str_dmd (WwLazy True) = WARN( case str_dmd of { WwLazy _ -> False; other -> True }, - ppr id <+> ppr orig_str_ds <+> ppr orig_abs_ds ) - WwLazy True -- Best of all + mk_dmd str_dmd (WwLazy True) + = WARN( not (res_bot || isLazy str_dmd), + ppr id <+> ppr orig_str_ds <+> ppr orig_abs_ds ) + -- If the arg isn't used we jolly well don't expect the function + -- to be strict in it. Unless the function diverges. + WwLazy True -- Best of all + mk_dmd (WwUnpack nd u str_ds) (WwUnpack _ _ abs_ds) = WwUnpack nd u (go str_ds abs_ds) @@ -733,12 +740,9 @@ findRecDemand str_fn abs_fn ty where is_numeric_type ty - = case (splitAlgTyConApp_maybe ty) of -- NB: duplicates stuff done above - Nothing -> False - Just (tycon, _, _) - | tyConUnique tycon `is_elem` numericTyKeys - -> True - _{-something else-} -> False + = case (splitTyConApp_maybe ty) of -- NB: duplicates stuff done above + Nothing -> False + Just (tycon, _) -> tyConUnique tycon `is_elem` numericTyKeys where is_elem = isIn "is_numeric_type" diff --git a/ghc/compiler/stranal/WwLib.lhs b/ghc/compiler/stranal/WwLib.lhs index 5fcb8d7db9..9083d37f81 100644 --- a/ghc/compiler/stranal/WwLib.lhs +++ b/ghc/compiler/stranal/WwLib.lhs @@ -22,7 +22,7 @@ import DataCon ( DataCon, splitProductType ) import Demand ( Demand(..), wwLazy, wwPrim ) import PrelInfo ( realWorldPrimId, aBSENT_ERROR_ID ) import TysPrim ( realWorldStatePrimTy ) -import TysWiredIn ( unboxedTupleCon, unboxedTupleTyCon ) +import TysWiredIn ( tupleCon ) import Type ( isUnLiftedType, splitForAllTys, splitFunTys, isAlgType, splitNewType_maybe, @@ -30,7 +30,7 @@ import Type ( isUnLiftedType, Type ) import TyCon ( isNewTyCon, isProductTyCon, TyCon ) -import BasicTypes ( NewOrData(..), Arity ) +import BasicTypes ( NewOrData(..), Arity, Boxity(..) ) import Var ( TyVar, Var, isId ) import UniqSupply ( returnUs, thenUs, getUniqueUs, getUniquesUs, mapUs, UniqSM ) @@ -497,7 +497,7 @@ mkWWcpr body_ty ReturnsCPR let (wrap_wild : work_wild : args) = zipWith mk_ww_local uniqs (ubx_tup_ty : body_ty : con_arg_tys) arg_vars = map Var args - ubx_tup_con = unboxedTupleCon n_con_args + ubx_tup_con = tupleCon Unboxed n_con_args ubx_tup_ty = exprType ubx_tup_app ubx_tup_app = mkConApp ubx_tup_con (map Type con_arg_tys ++ arg_vars) con_app = mkConApp data_con (map Type tycon_arg_tys ++ arg_vars) diff --git a/ghc/compiler/typecheck/Inst.lhs b/ghc/compiler/typecheck/Inst.lhs index f00e8a1418..9d96872679 100644 --- a/ghc/compiler/typecheck/Inst.lhs +++ b/ghc/compiler/typecheck/Inst.lhs @@ -50,7 +50,7 @@ import TcType ( TcThetaType, zonkTcThetaType ) import Bag -import Class ( classInstEnv, Class ) +import Class ( classInstEnv, Class, FunDep ) import FunDeps ( instantiateFdClassTys ) import Id ( Id, idFreeTyVars, idType, mkUserLocal, mkSysLocal ) import PrelInfo ( isStandardClass, isCcallishClass, isNoDictClass ) @@ -176,7 +176,7 @@ data Inst | FunDep Class -- the class from which this arises - [([TcType], [TcType])] + [FunDep TcType] InstLoc data OverloadedLit @@ -193,48 +193,25 @@ maps to do their stuff. \begin{code} instance Ord Inst where compare = cmpInst -instance Ord PredType where - compare = cmpPred instance Eq Inst where (==) i1 i2 = case i1 `cmpInst` i2 of EQ -> True other -> False -instance Eq PredType where - (==) p1 p2 = case p1 `cmpPred` p2 of - EQ -> True - other -> False -cmpInst (Dict _ pred1 _) (Dict _ pred2 _) - = (pred1 `cmpPred` pred2) -cmpInst (Dict _ _ _) other - = LT - -cmpInst (Method _ _ _ _ _ _) (Dict _ _ _) - = GT -cmpInst (Method _ id1 tys1 _ _ _) (Method _ id2 tys2 _ _ _) - = (id1 `compare` id2) `thenCmp` (tys1 `compare` tys2) -cmpInst (Method _ _ _ _ _ _) other - = LT - -cmpInst (LitInst _ lit1 ty1 _) (LitInst _ lit2 ty2 _) - = (lit1 `cmpOverLit` lit2) `thenCmp` (ty1 `compare` ty2) -cmpInst (LitInst _ _ _ _) (FunDep _ _ _) - = LT -cmpInst (LitInst _ _ _ _) other - = GT - -cmpInst (FunDep clas1 fds1 _) (FunDep clas2 fds2 _) - = (clas1 `compare` clas2) `thenCmp` (fds1 `compare` fds2) -cmpInst (FunDep _ _ _) other - = GT - -cmpPred (Class c1 tys1) (Class c2 tys2) - = (c1 `compare` c2) `thenCmp` (tys1 `compare` tys2) -cmpPred (IParam n1 ty1) (IParam n2 ty2) - = (n1 `compare` n2) `thenCmp` (ty1 `compare` ty2) -cmpPred (Class _ _) (IParam _ _) = LT -cmpPred _ _ = GT +cmpInst (Dict _ pred1 _) (Dict _ pred2 _) = (pred1 `compare` pred2) +cmpInst (Dict _ _ _) other = LT + +cmpInst (Method _ _ _ _ _ _) (Dict _ _ _) = GT +cmpInst (Method _ id1 tys1 _ _ _) (Method _ id2 tys2 _ _ _) = (id1 `compare` id2) `thenCmp` (tys1 `compare` tys2) +cmpInst (Method _ _ _ _ _ _) other = LT + +cmpInst (LitInst _ lit1 ty1 _) (LitInst _ lit2 ty2 _) = (lit1 `cmpOverLit` lit2) `thenCmp` (ty1 `compare` ty2) +cmpInst (LitInst _ _ _ _) (FunDep _ _ _) = LT +cmpInst (LitInst _ _ _ _) other = GT + +cmpInst (FunDep clas1 fds1 _) (FunDep clas2 fds2 _) = (clas1 `compare` clas2) `thenCmp` (fds1 `compare` fds2) +cmpInst (FunDep _ _ _) other = GT cmpOverLit (OverloadedIntegral i1) (OverloadedIntegral i2) = i1 `compare` i2 cmpOverLit (OverloadedFractional f1) (OverloadedFractional f2) = f1 `compare` f2 @@ -400,10 +377,11 @@ newMethod orig id tys newMethodWithGivenTy orig id tys theta tau `thenNF_Tc` \ meth_inst -> returnNF_Tc (unitLIE meth_inst, instToId meth_inst) -instOverloadedFun orig (HsVar v) arg_tys theta tau +instOverloadedFun orig v arg_tys theta tau +-- This is where we introduce new functional dependencies into the LIE = newMethodWithGivenTy orig v arg_tys theta tau `thenNF_Tc` \ inst -> instFunDeps orig theta `thenNF_Tc` \ fds -> - returnNF_Tc (HsVar (instToId inst), mkLIE (inst : fds)) + returnNF_Tc (instToId inst, mkLIE (inst : fds)) instFunDeps orig theta = tcGetInstLoc orig `thenNF_Tc` \ loc -> diff --git a/ghc/compiler/typecheck/TcBinds.lhs b/ghc/compiler/typecheck/TcBinds.lhs index 92a82b5d79..52f1840ade 100644 --- a/ghc/compiler/typecheck/TcBinds.lhs +++ b/ghc/compiler/typecheck/TcBinds.lhs @@ -25,7 +25,7 @@ import Inst ( Inst, LIE, emptyLIE, mkLIE, plusLIE, plusLIEs, InstOrigin(..), ) import TcEnv ( tcExtendLocalValEnv, newSpecPragmaId, newLocalId, - tcLookupTyCon, + tcLookupTyConByKey, tcGetGlobalTyVars, tcExtendGlobalTyVars ) import TcSimplify ( tcSimplify, tcSimplifyAndCheck, tcSimplifyToDicts ) @@ -42,8 +42,6 @@ import TcType ( TcType, TcThetaType, ) import TcUnify ( unifyTauTy, unifyTauTyLists ) -import PrelInfo ( main_NAME, ioTyCon_NAME ) - import Id ( Id, mkVanillaId, setInlinePragma, idFreeTyVars ) import Var ( idType, idName ) import IdInfo ( setInlinePragInfo, InlinePragInfo(..) ) @@ -62,6 +60,7 @@ import Util ( isIn ) import Maybes ( maybeToBool ) import BasicTypes ( TopLevelFlag(..), RecFlag(..), isNotTopLevel ) import FiniteMap ( listToFM, lookupFM ) +import Unique ( ioTyConKey, mainKey, hasKey, Uniquable(..) ) import SrcLoc ( SrcLoc ) import Outputable \end{code} @@ -541,13 +540,20 @@ getTyVarsToGen is_unrestricted mono_id_tys lie zonkTcTypes mono_id_tys `thenNF_Tc` \ zonked_mono_id_tys -> let body_tyvars = tyVarsOfTypes zonked_mono_id_tys `minusVarSet` free_tyvars + fds = getAllFunDepsOfLIE lie in if is_unrestricted then - let fds = getAllFunDepsOfLIE lie in + -- We need to augment the type variables that appear explicitly in + -- the type by those that are determined by the functional dependencies. + -- e.g. suppose our type is C a b => a -> a + -- with the fun-dep a->b + -- Then we should generalise over b too; otherwise it will be + -- reported as ambiguous. zonkFunDeps fds `thenNF_Tc` \ fds' -> - let tvFundep = tyVarFunDep fds' - extended_tyvars = oclose tvFundep body_tyvars in + let tvFundep = tyVarFunDep fds' + extended_tyvars = oclose tvFundep body_tyvars + in -- pprTrace "gTVTG" (ppr (lie, body_tyvars, extended_tyvars)) $ returnNF_Tc (emptyVarSet, extended_tyvars) else @@ -734,7 +740,7 @@ checkSigMatch top_lvl binder_names mono_ids sigs | main_bound_here = -- First unify the main_id with IO t, for any old t tcSetErrCtxt mainTyCheckCtxt ( - tcLookupTyCon ioTyCon_NAME `thenTc` \ ioTyCon -> + tcLookupTyConByKey ioTyConKey `thenTc` \ ioTyCon -> newTyVarTy boxedTypeKind `thenNF_Tc` \ t_tv -> unifyTauTy ((mkTyConApp ioTyCon [t_tv])) (idType main_mono_id) @@ -808,8 +814,8 @@ checkSigMatch top_lvl binder_names mono_ids sigs find_main NotTopLevel binder_names mono_ids = Nothing find_main TopLevel binder_names mono_ids = go binder_names mono_ids go [] [] = Nothing - go (n:ns) (m:ms) | n == main_NAME = Just m - | otherwise = go ns ms + go (n:ns) (m:ms) | n `hasKey` mainKey = Just m + | otherwise = go ns ms \end{code} @@ -936,13 +942,13 @@ sigContextsCtxt s1 s2 4 (ptext SLIT("(the signature contexts in a mutually recursive group should all be identical)")) mainContextsErr id - | getName id == main_NAME = ptext SLIT("Main.main cannot be overloaded") + | id `hasKey` mainKey = ptext SLIT("Main.main cannot be overloaded") | otherwise = quotes (ppr id) <+> ptext SLIT("cannot be overloaded") <> char ',' <> -- sigh; workaround for cpp's inability to deal ptext SLIT("because it is mutually recursive with Main.main") -- with commas inside SLIT strings. mainTyCheckCtxt - = hsep [ptext SLIT("When checking that"), quotes (ppr main_NAME), + = hsep [ptext SLIT("When checking that"), quotes (ptext SLIT("main")), ptext SLIT("has the required type")] ----------------------------------------------- diff --git a/ghc/compiler/typecheck/TcClassDcl.lhs b/ghc/compiler/typecheck/TcClassDcl.lhs index a046545416..8e38983d12 100644 --- a/ghc/compiler/typecheck/TcClassDcl.lhs +++ b/ghc/compiler/typecheck/TcClassDcl.lhs @@ -13,7 +13,7 @@ module TcClassDcl ( kcClassDecl, tcClassDecl1, tcClassDecls2, mkImplicitClassBin import HsSyn ( HsDecl(..), TyClDecl(..), Sig(..), MonoBinds(..), InPat(..), HsBinds(..), GRHSs(..), HsExpr(..), HsLit(..), HsType(..), HsPred(..), - pprHsClassAssertion, mkSimpleMatch, + mkSimpleMatch, andMonoBinds, andMonoBindList, getTyVarName, isClassDecl, isClassOpSig, isPragSig, collectMonoBinders ) @@ -27,7 +27,7 @@ import TcHsSyn ( TcMonoBinds, idsToMonoBinds ) import Inst ( Inst, InstOrigin(..), LIE, emptyLIE, plusLIE, plusLIEs, newDicts, newMethod ) import TcEnv ( TcId, ValueEnv, TcTyThing(..), tcAddImportedIdInfo, - tcLookupClass, tcLookupTy, tcExtendTyVarEnvForMeths, tcExtendGlobalTyVars, + tcLookupTy, tcExtendTyVarEnvForMeths, tcExtendGlobalTyVars, tcExtendLocalValEnv ) import TcBinds ( tcBindWithSigs, tcSpecSigs ) @@ -117,7 +117,7 @@ kcClassDecl (ClassDecl context class_name (classArityErr class_name) `thenTc_` -- Get the (mutable) class kind - tcLookupTy class_name `thenNF_Tc` \ (kind, _, _) -> + tcLookupTy class_name `thenNF_Tc` \ (kind, _) -> -- Make suitable tyvars and do kind checking -- The net effect is to mutate the class kind @@ -145,7 +145,7 @@ tcClassDecl1 rec_env rec_inst_mapper rec_vrcs tyvar_names fundeps class_sigs def_methods pragmas tycon_name datacon_name datacon_wkr_name sc_sel_names src_loc) = -- LOOK THINGS UP IN THE ENVIRONMENT - tcLookupTy class_name `thenTc` \ (class_kind, _, AClass rec_class) -> + tcLookupTy class_name `thenTc` \ (class_kind, AClass rec_class arity) -> tcExtendTopTyVarScope class_kind tyvar_names $ \ tyvars _ -> -- The class kind is by now immutable @@ -201,7 +201,7 @@ tcClassDecl1 rec_env rec_inst_mapper rec_vrcs clas -- Yes! It's a dictionary new_or_data in - returnTc clas + returnTc (class_name, AClass clas arity) \end{code} \begin{code} @@ -211,10 +211,8 @@ tc_fundep (us, vs) = mapTc tc_fd_tyvar vs `thenTc` \ vs' -> returnTc (us', vs') tc_fd_tyvar v = - tcLookupTy v `thenTc` \(_, _, thing) -> - case thing of - ATyVar tv -> returnTc tv - -- ZZ else should fail more gracefully + tcLookupTy v `thenTc` \(_, ATyVar tv) -> + returnTc tv \end{code} \begin{code} @@ -248,11 +246,11 @@ tcClassContext class_name rec_class rec_tyvars context sc_sel_names returnTc (sc_theta', sc_tys, sc_sel_ids) where - check_constraint (HsPClass c tys) = checkTc (all is_tyvar tys) - (superClassErr class_name (c, tys)) + check_constraint sc@(HsPClass c tys) = checkTc (all is_tyvar tys) + (superClassErr class_name sc) - is_tyvar (MonoTyVar _) = True - is_tyvar other = False + is_tyvar (HsTyVar _) = True + is_tyvar other = False tcClassSig :: ValueEnv -- Knot tying only! @@ -342,7 +340,7 @@ tcClassDecl2 (ClassDecl context class_name | otherwise -- It is locally defined = recoverNF_Tc (returnNF_Tc (emptyLIE, EmptyMonoBinds)) $ tcAddSrcLoc src_loc $ - tcLookupClass class_name `thenNF_Tc` \ clas -> + tcLookupTy class_name `thenNF_Tc` \ (_, AClass clas _) -> tcDefaultMethodBinds clas default_binds class_sigs \end{code} @@ -642,7 +640,7 @@ classArityErr class_name = ptext SLIT("Too many parameters for class") <+> quotes (ppr class_name) superClassErr class_name sc - = ptext SLIT("Illegal superclass constraint") <+> quotes (pprHsClassAssertion sc) + = ptext SLIT("Illegal superclass constraint") <+> quotes (ppr sc) <+> ptext SLIT("in declaration for class") <+> quotes (ppr class_name) defltMethCtxt class_name diff --git a/ghc/compiler/typecheck/TcDeriv.lhs b/ghc/compiler/typecheck/TcDeriv.lhs index efa3e3de7b..58c39805ba 100644 --- a/ghc/compiler/typecheck/TcDeriv.lhs +++ b/ghc/compiler/typecheck/TcDeriv.lhs @@ -41,7 +41,7 @@ import Name ( isLocallyDefined, getSrcLoc, OccName, nameOccName ) import RdrName ( RdrName ) -import RnMonad ( Fixities ) +import RnMonad ( FixityEnv ) import SrcLoc ( mkGeneratedSrcLoc, SrcLoc ) import TyCon ( tyConTyVars, tyConDataCons, tyConDerivings, tyConTheta, maybeTyConSingleCon, isDataTyCon, @@ -188,7 +188,7 @@ context to the instance decl. The "offending classes" are \begin{code} tcDeriving :: ModuleName -- name of module under scrutiny - -> Fixities -- for the deriving code (Show/Read.) + -> FixityEnv -- for the deriving code (Show/Read.) -> RnNameSupply -- for "renaming" bits of generated code -> Bag InstInfo -- What we already know about instances -> TcM s (Bag InstInfo, -- The generated "instance decls". @@ -352,14 +352,12 @@ makeDerivEqns ------------------------------------------------------------------ chk_out :: Class -> TyCon -> Maybe Message chk_out clas tycon - | clas_key == enumClassKey && not is_enumeration = bog_out nullary_why - | clas_key == boundedClassKey && not is_enumeration_or_single = bog_out single_nullary_why - | clas_key == ixClassKey && not is_enumeration_or_single = bog_out single_nullary_why + | clas `hasKey` enumClassKey && not is_enumeration = bog_out nullary_why + | clas `hasKey` boundedClassKey && not is_enumeration_or_single = bog_out single_nullary_why + | clas `hasKey` ixClassKey && not is_enumeration_or_single = bog_out single_nullary_why | any isExistentialDataCon (tyConDataCons tycon) = Just (existentialErr clas tycon) | otherwise = Nothing where - clas_key = classKey clas - is_enumeration = isEnumerationTyCon tycon is_single_con = maybeToBool (maybeTyConSingleCon tycon) is_enumeration_or_single = is_enumeration || is_single_con @@ -555,13 +553,13 @@ the renamer. What a great hack! -- Generate the method bindings for the required instance -- (paired with class name, as we need that when generating dict -- names.) -gen_bind :: Fixities -> InstInfo -> ({-class-}OccName, {-tyCon-}OccName, RdrNameMonoBinds) +gen_bind :: FixityEnv -> InstInfo -> ({-class-}OccName, {-tyCon-}OccName, RdrNameMonoBinds) gen_bind fixities (InstInfo clas _ [ty] _ _ _ _ _) | not from_here = (clas_nm, tycon_nm, EmptyMonoBinds) - | ckey == showClassKey + | clas `hasKey` showClassKey = (clas_nm, tycon_nm, gen_Show_binds fixities tycon) - | ckey == readClassKey + | clas `hasKey` readClassKey = (clas_nm, tycon_nm, gen_Read_binds fixities tycon) | otherwise = (clas_nm, tycon_nm, @@ -572,15 +570,13 @@ gen_bind fixities (InstInfo clas _ [ty] _ _ _ _ _) ,(boundedClassKey, gen_Bounded_binds) ,(ixClassKey, gen_Ix_binds) ] - ckey + (classKey clas) tycon) where clas_nm = nameOccName (getName clas) tycon_nm = nameOccName (getName tycon) from_here = isLocallyDefined tycon (tycon,_,_) = splitAlgTyConApp ty - ckey = classKey clas - gen_inst_info :: InstInfo -> (Name, RenamedMonoBinds) diff --git a/ghc/compiler/typecheck/TcEnv.lhs b/ghc/compiler/typecheck/TcEnv.lhs index 8e546feab2..d07c219b46 100644 --- a/ghc/compiler/typecheck/TcEnv.lhs +++ b/ghc/compiler/typecheck/TcEnv.lhs @@ -5,15 +5,15 @@ module TcEnv( TcEnv, ValueEnv, TcTyThing(..), - initEnv, getEnvTyCons, getEnvClasses, getAllEnvTyCons, + initEnv, getEnvTyCons, getEnvClasses, getEnvAllTyCons, tcExtendUVarEnv, tcLookupUVar, tcExtendTyVarEnv, tcExtendTyVarEnvForMeths, tcExtendTypeEnv, tcGetInScopeTyVars, tcLookupTy, - tcLookupTyCon, tcLookupTyConByKey, - tcLookupClass, tcLookupClassByKey, tcLookupClassByKey_maybe, + tcLookupTyConByKey, + tcLookupClassByKey, tcLookupClassByKey_maybe, tcExtendGlobalValEnv, tcExtendLocalValEnv, tcGetValueEnv, tcSetValueEnv, @@ -32,7 +32,7 @@ module TcEnv( #include "HsVersions.h" -import HsTypes ( HsTyVar, getTyVarName ) +import HsTypes ( HsTyVarBndr, getTyVarName ) import Id ( mkUserLocal, isDataConWrapId_maybe ) import MkId ( mkSpecPragmaId ) import Var ( TyVar, Id, setVarName, @@ -150,7 +150,7 @@ data TcEnv = TcEnv type NameEnv val = UniqFM val -- Keyed by Names type UsageEnv = NameEnv UVar -type TypeEnv = NameEnv (TcKind, Maybe Arity, TcTyThing) +type TypeEnv = NameEnv (TcKind, TcTyThing) type ValueEnv = NameEnv Id valueEnvIds :: ValueEnv -> [Id] @@ -159,20 +159,29 @@ valueEnvIds ve = eltsUFM ve data TcTyThing = ATyVar TcTyVar -- Mutable only so that the kind can be mutable -- if the kind is mutable, the tyvar must be so that -- zonking works - | ATyCon TyCon - | AClass Class + | ADataTyCon TyCon + | ASynTyCon TyCon Arity + | AClass Class Arity initEnv :: TcRef TcTyVarSet -> TcEnv initEnv mut = TcEnv emptyUFM emptyUFM emptyUFM (emptyVarSet, mut) -getEnvTyCons (TcEnv _ te _ _) = [tc | (_, _, ATyCon tc) <- eltsUFM te] -getEnvClasses (TcEnv _ te _ _) = [cl | (_, _, AClass cl) <- eltsUFM te] -getAllEnvTyCons (TcEnv _ te _ _) = catMaybes (map gettc (eltsUFM te)) +getEnvClasses (TcEnv _ te _ _) = [cl | (_, AClass cl _) <- eltsUFM te] + +getEnvTyCons (TcEnv _ te _ _) = catMaybes (map get_tc (eltsUFM te)) + where + get_tc (_, ADataTyCon tc) = Just tc + get_tc (_, ASynTyCon tc _) = Just tc + get_tc other = Nothing + +getEnvAllTyCons te_list = catMaybes (map get_tc te_list) + -- The 'all' means 'including the tycons from class decls' where - gettc (_,_, ATyCon tc) = Just tc - gettc (_,_, AClass cl) = Just (classTyCon cl) - gettc _ = Nothing + get_tc (_, ADataTyCon tc) = Just tc + get_tc (_, ASynTyCon tc _) = Just tc + get_tc (_, AClass cl _) = Just (classTyCon cl) + get_tc other = Nothing \end{code} The UsageEnv @@ -209,7 +218,7 @@ tcExtendTyVarEnv :: [TyVar] -> TcM s r -> TcM s r tcExtendTyVarEnv tyvars scope = tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve (in_scope_tvs, gtvs)) -> let - extend_list = [ (getName tv, (kindToTcKind (tyVarKind tv), Nothing, ATyVar tv)) + extend_list = [ (getName tv, (kindToTcKind (tyVarKind tv), ATyVar tv)) | tv <- tyvars ] te' = addListToUFM te extend_list @@ -239,7 +248,7 @@ tcExtendTyVarEnvForMeths sig_tyvars inst_tyvars thing_inside in tcSetEnv (TcEnv ue te' ve gtvs) thing_inside where - stuff = [ (getName sig_tv, (kindToTcKind (tyVarKind inst_tv), Nothing, ATyVar inst_tv)) + stuff = [ (getName sig_tv, (kindToTcKind (tyVarKind inst_tv), ATyVar inst_tv)) | (sig_tv, inst_tv) <- zipEqual "tcMeth" sig_tyvars inst_tyvars ] @@ -282,9 +291,9 @@ tcGetInScopeTyVars Type constructors and classes \begin{code} -tcExtendTypeEnv :: [(Name, (TcKind, Maybe Arity, TcTyThing))] -> TcM s r -> TcM s r +tcExtendTypeEnv :: [(Name, (TcKind, TcTyThing))] -> TcM s r -> TcM s r tcExtendTypeEnv bindings scope - = ASSERT( null [tv | (_, (_,_,ATyVar tv)) <- bindings] ) + = ASSERT( null [tv | (_, (_,ATyVar tv)) <- bindings] ) -- Not for tyvars; use tcExtendTyVarEnv tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve gtvs) -> let @@ -297,7 +306,7 @@ tcExtendTypeEnv bindings scope Looking up in the environments. \begin{code} -tcLookupTy :: Name -> NF_TcM s (TcKind, Maybe Arity, TcTyThing) +tcLookupTy :: Name -> NF_TcM s (TcKind, TcTyThing) tcLookupTy name = tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve gtvs) -> case lookupUFM te name of { @@ -305,46 +314,35 @@ tcLookupTy name Nothing -> case maybeWiredInTyConName name of - Just tc -> returnNF_Tc (kindToTcKind (tyConKind tc), maybe_arity, ATyCon tc) - where - maybe_arity | isSynTyCon tc = Just (tyConArity tc) - | otherwise = Nothing + Just tc | isSynTyCon tc -> returnNF_Tc (kindToTcKind (tyConKind tc), ASynTyCon tc (tyConArity tc)) + | otherwise -> returnNF_Tc (kindToTcKind (tyConKind tc), ADataTyCon tc) Nothing -> -- This can happen if an interface-file -- unfolding is screwed up failWithTc (tyNameOutOfScope name) } -tcLookupClass :: Name -> NF_TcM s Class -tcLookupClass name - = tcLookupTy name `thenNF_Tc` \ (_, _, AClass clas) -> - returnNF_Tc clas - -tcLookupTyCon :: Name -> NF_TcM s TyCon -tcLookupTyCon name - = tcLookupTy name `thenNF_Tc` \ (_, _, ATyCon tycon) -> - returnNF_Tc tycon - tcLookupClassByKey :: Unique -> NF_TcM s Class tcLookupClassByKey key = tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve gtvs) -> case lookupUFM_Directly te key of - Just (_, _, AClass cl) -> returnNF_Tc cl - other -> pprPanic "tcLookupClassByKey:" (pprUnique10 key) + Just (_, AClass cl _) -> returnNF_Tc cl + other -> pprPanic "tcLookupClassByKey:" (pprUnique10 key) tcLookupClassByKey_maybe :: Unique -> NF_TcM s (Maybe Class) tcLookupClassByKey_maybe key = tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve gtvs) -> case lookupUFM_Directly te key of - Just (_, _, AClass cl) -> returnNF_Tc (Just cl) - other -> returnNF_Tc Nothing + Just (_, AClass cl _) -> returnNF_Tc (Just cl) + other -> returnNF_Tc Nothing tcLookupTyConByKey :: Unique -> NF_TcM s TyCon tcLookupTyConByKey key = tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve gtvs) -> case lookupUFM_Directly te key of - Just (_, _, ATyCon tc) -> returnNF_Tc tc - other -> pprPanic "tcLookupTyConByKey:" (pprUnique10 key) + Just (_, ADataTyCon tc) -> returnNF_Tc tc + Just (_, ASynTyCon tc _) -> returnNF_Tc tc + other -> pprPanic "tcLookupTyConByKey:" (pprUnique10 key) \end{code} diff --git a/ghc/compiler/typecheck/TcExpr.lhs b/ghc/compiler/typecheck/TcExpr.lhs index e556db187c..2bb3060185 100644 --- a/ghc/compiler/typecheck/TcExpr.lhs +++ b/ghc/compiler/typecheck/TcExpr.lhs @@ -32,7 +32,7 @@ import TcEnv ( tcInstId, tcLookupValue, tcLookupClassByKey, tcLookupValueByKey, tcExtendGlobalTyVars, tcLookupValueMaybe, - tcLookupTyCon, tcLookupDataCon + tcLookupTyConByKey, tcLookupDataCon ) import TcMatches ( tcMatchesCase, tcMatchLambda, tcStmts ) import TcMonoType ( tcHsSigType, checkSigTyVars, sigCtxt ) @@ -72,13 +72,11 @@ import TysPrim ( intPrimTy, charPrimTy, doublePrimTy, floatPrimTy, addrPrimTy ) import TysWiredIn ( boolTy, charTy, stringTy ) -import PrelInfo ( ioTyCon_NAME ) -import TcUnify ( unifyTauTy, unifyFunTy, unifyListTy, unifyTupleTy, - unifyUnboxedTupleTy ) +import TcUnify ( unifyTauTy, unifyFunTy, unifyListTy, unifyTupleTy ) import Unique ( cCallableClassKey, cReturnableClassKey, enumFromClassOpKey, enumFromThenClassOpKey, enumFromToClassOpKey, enumFromThenToClassOpKey, - thenMClassOpKey, failMClassOpKey, returnMClassOpKey + thenMClassOpKey, failMClassOpKey, returnMClassOpKey, ioTyConKey ) import Outputable import Maybes ( maybeToBool, mapMaybe ) @@ -359,7 +357,7 @@ tcMonoExpr (HsCCall lbl args may_gc is_asm ignored_fake_result_ty) res_ty = -- Get the callable and returnable classes. tcLookupClassByKey cCallableClassKey `thenNF_Tc` \ cCallableClass -> tcLookupClassByKey cReturnableClassKey `thenNF_Tc` \ cReturnableClass -> - tcLookupTyCon ioTyCon_NAME `thenNF_Tc` \ ioTyCon -> + tcLookupTyConByKey ioTyConKey `thenNF_Tc` \ ioTyCon -> let new_arg_dict (arg, arg_ty) = newClassDicts (CCallOrigin (_UNPK_ lbl) (Just arg)) @@ -462,15 +460,12 @@ tcMonoExpr in_expr@(ExplicitList exprs) res_ty -- Non-empty list = tcAddErrCtxt (listCtxt expr) $ tcMonoExpr expr elt_ty -tcMonoExpr (ExplicitTuple exprs boxed) res_ty - = (if boxed - then unifyTupleTy (length exprs) res_ty - else unifyUnboxedTupleTy (length exprs) res_ty - ) `thenTc` \ arg_tys -> +tcMonoExpr (ExplicitTuple exprs boxity) res_ty + = unifyTupleTy boxity (length exprs) res_ty `thenTc` \ arg_tys -> mapAndUnzipTc (\ (expr, arg_ty) -> tcMonoExpr expr arg_ty) (exprs `zip` arg_tys) -- we know they're of equal length. `thenTc` \ (exprs', lies) -> - returnTc (ExplicitTuple exprs' boxed, plusLIEs lies) + returnTc (ExplicitTuple exprs' boxity, plusLIEs lies) tcMonoExpr expr@(RecordCon con_name rbinds) res_ty = tcAddErrCtxt (recordConCtxt expr) $ @@ -897,11 +892,11 @@ tcId name tcLookupValueMaybe name `thenNF_Tc` \ maybe_local -> case maybe_local of - Just tc_id -> instantiate_it (OccurrenceOf tc_id) (HsVar tc_id) (unannotTy (idType tc_id)) + Just tc_id -> instantiate_it (OccurrenceOf tc_id) tc_id (unannotTy (idType tc_id)) Nothing -> tcLookupValue name `thenNF_Tc` \ id -> tcInstId id `thenNF_Tc` \ (tyvars, theta, tau) -> - instantiate_it2 (OccurrenceOf id) (HsVar id) tyvars theta tau + instantiate_it2 (OccurrenceOf id) id tyvars theta tau where -- The instantiate_it loop runs round instantiating the Id. @@ -917,7 +912,7 @@ tcId name instantiate_it2 orig fun tyvars theta tau = if null theta then -- Is it overloaded? - returnNF_Tc (mkHsTyApp fun arg_tys, emptyLIE, tau) + returnNF_Tc (mkHsTyApp (HsVar fun) arg_tys, emptyLIE, tau) else -- Yes, it's overloaded instOverloadedFun orig fun arg_tys theta tau `thenNF_Tc` \ (fun', lie1) -> diff --git a/ghc/compiler/typecheck/TcForeign.lhs b/ghc/compiler/typecheck/TcForeign.lhs index e814e06386..aa2434704a 100644 --- a/ghc/compiler/typecheck/TcForeign.lhs +++ b/ghc/compiler/typecheck/TcForeign.lhs @@ -207,7 +207,7 @@ checkForeignRes :: Bool -> (Type -> Bool) -> Type -> TcM s () checkForeignRes non_io_result_ok pred_res_ty ty = case (splitTyConApp_maybe ty) of Just (io, [res_ty]) - | (getUnique io) == ioTyConKey && pred_res_ty res_ty + | io `hasKey` ioTyConKey && pred_res_ty res_ty -> returnTc () _ -> check (non_io_result_ok && pred_res_ty ty) diff --git a/ghc/compiler/typecheck/TcGenDeriv.lhs b/ghc/compiler/typecheck/TcGenDeriv.lhs index 20e59ebefc..d216ae6409 100644 --- a/ghc/compiler/typecheck/TcGenDeriv.lhs +++ b/ghc/compiler/typecheck/TcGenDeriv.lhs @@ -33,9 +33,10 @@ import HsSyn ( InPat(..), HsExpr(..), MonoBinds(..), ) import RdrHsSyn ( mkOpApp, RdrNameMonoBinds, RdrNameHsExpr, RdrNamePat ) import RdrName ( RdrName, mkSrcUnqual ) -import RnMonad ( Fixities ) +import RnMonad ( FixityEnv, lookupFixity ) import BasicTypes ( RecFlag(..), Fixity(..), FixityDirection(..) , maxPrecedence, defaultFixity + , Boxity(..) ) import FieldLabel ( fieldLabelName ) import DataCon ( isNullaryDataCon, dataConTag, @@ -648,7 +649,7 @@ gen_Ix_binds tycon enum_range = mk_easy_FunMonoBind tycon_loc range_RDR - [TuplePatIn [a_Pat, b_Pat] True{-boxed-}] [] $ + [TuplePatIn [a_Pat, b_Pat] Boxed] [] $ untag_Expr tycon [(a_RDR, ah_RDR)] $ untag_Expr tycon [(b_RDR, bh_RDR)] $ HsApp (mk_easy_App map_RDR [tag2con_RDR tycon]) $ @@ -658,7 +659,7 @@ gen_Ix_binds tycon enum_index = mk_easy_FunMonoBind tycon_loc index_RDR - [AsPatIn c_RDR (TuplePatIn [a_Pat, wildPat] True{-boxed-}), + [AsPatIn c_RDR (TuplePatIn [a_Pat, wildPat] Boxed), d_Pat] [] ( HsIf (HsPar (mk_easy_App inRange_RDR [c_RDR, d_RDR])) ( untag_Expr tycon [(a_RDR, ah_RDR)] ( @@ -678,7 +679,7 @@ gen_Ix_binds tycon enum_inRange = mk_easy_FunMonoBind tycon_loc inRange_RDR - [TuplePatIn [a_Pat, b_Pat] True{-boxed-}, c_Pat] [] ( + [TuplePatIn [a_Pat, b_Pat] Boxed, c_Pat] [] ( untag_Expr tycon [(a_RDR, ah_RDR)] ( untag_Expr tycon [(b_RDR, bh_RDR)] ( untag_Expr tycon [(c_RDR, ch_RDR)] ( @@ -715,7 +716,7 @@ gen_Ix_binds tycon -------------------------------------------------------------- single_con_range = mk_easy_FunMonoBind tycon_loc range_RDR - [TuplePatIn [con_pat as_needed, con_pat bs_needed] True{-boxed-}] [] $ + [TuplePatIn [con_pat as_needed, con_pat bs_needed] Boxed] [] $ HsDo ListComp stmts tycon_loc where stmts = zipWith3Equal "single_con_range" mk_qual as_needed bs_needed cs_needed @@ -724,45 +725,45 @@ gen_Ix_binds tycon mk_qual a b c = BindStmt (VarPatIn c) (HsApp (HsVar range_RDR) - (ExplicitTuple [HsVar a, HsVar b] True)) + (ExplicitTuple [HsVar a, HsVar b] Boxed)) tycon_loc ---------------- single_con_index = mk_easy_FunMonoBind tycon_loc index_RDR - [TuplePatIn [con_pat as_needed, con_pat bs_needed] True, + [TuplePatIn [con_pat as_needed, con_pat bs_needed] Boxed, con_pat cs_needed] [range_size] ( foldl mk_index (HsLit (HsInt 0)) (zip3 as_needed bs_needed cs_needed)) where mk_index multiply_by (l, u, i) = genOpApp ( (HsApp (HsApp (HsVar index_RDR) - (ExplicitTuple [HsVar l, HsVar u] True)) (HsVar i)) + (ExplicitTuple [HsVar l, HsVar u] Boxed)) (HsVar i)) ) plus_RDR ( genOpApp ( (HsApp (HsVar rangeSize_RDR) - (ExplicitTuple [HsVar l, HsVar u] True)) + (ExplicitTuple [HsVar l, HsVar u] Boxed)) ) times_RDR multiply_by ) range_size = mk_easy_FunMonoBind tycon_loc rangeSize_RDR - [TuplePatIn [a_Pat, b_Pat] True] [] ( + [TuplePatIn [a_Pat, b_Pat] Boxed] [] ( genOpApp ( (HsApp (HsApp (HsVar index_RDR) - (ExplicitTuple [a_Expr, b_Expr] True)) b_Expr) + (ExplicitTuple [a_Expr, b_Expr] Boxed)) b_Expr) ) plus_RDR (HsLit (HsInt 1))) ------------------ single_con_inRange = mk_easy_FunMonoBind tycon_loc inRange_RDR - [TuplePatIn [con_pat as_needed, con_pat bs_needed] True, + [TuplePatIn [con_pat as_needed, con_pat bs_needed] Boxed, con_pat cs_needed] [] ( foldl1 and_Expr (zipWith3Equal "single_con_inRange" in_range as_needed bs_needed cs_needed)) where in_range a b c = HsApp (HsApp (HsVar inRange_RDR) - (ExplicitTuple [HsVar a, HsVar b] True)) + (ExplicitTuple [HsVar a, HsVar b] Boxed)) (HsVar c) \end{code} @@ -773,9 +774,9 @@ gen_Ix_binds tycon %************************************************************************ \begin{code} -gen_Read_binds :: Fixities -> TyCon -> RdrNameMonoBinds +gen_Read_binds :: FixityEnv -> TyCon -> RdrNameMonoBinds -gen_Read_binds fixities tycon +gen_Read_binds fixity_env tycon = reads_prec `AndMonoBinds` read_list where tycon_loc = getSrcLoc tycon @@ -822,25 +823,25 @@ gen_Read_binds fixities tycon con_qual | not is_infix = BindStmt - (TuplePatIn [LitPatIn (mkHsString data_con_str), d_Pat] True) + (TuplePatIn [LitPatIn (mkHsString data_con_str), d_Pat] Boxed) (HsApp (HsVar lex_RDR) c_Expr) tycon_loc | otherwise = BindStmt - (TuplePatIn [LitPatIn (mkHsString data_con_str), VarPatIn bs2] True) + (TuplePatIn [LitPatIn (mkHsString data_con_str), VarPatIn bs2] Boxed) (HsApp (HsVar lex_RDR) (HsVar bs1)) tycon_loc str_qual str res draw_from = BindStmt - (TuplePatIn [LitPatIn (mkHsString str), VarPatIn res] True) + (TuplePatIn [LitPatIn (mkHsString str), VarPatIn res] Boxed) (HsApp (HsVar lex_RDR) draw_from) tycon_loc str_qual_paren str res draw_from = BindStmt - (TuplePatIn [LitPatIn (mkHsString str), VarPatIn res] True) + (TuplePatIn [LitPatIn (mkHsString str), VarPatIn res] Boxed) (HsApp (readParen_Expr true_Expr (HsVar lex_RDR)) draw_from) tycon_loc @@ -895,15 +896,15 @@ gen_Read_binds fixities tycon mk_read_qual p con_field res draw_from = BindStmt - (TuplePatIn [VarPatIn con_field, VarPatIn res] True) + (TuplePatIn [VarPatIn con_field, VarPatIn res] Boxed) (HsApp (HsApp (HsVar readsPrec_RDR) (HsLit (HsInt p))) draw_from) tycon_loc result_expr = ExplicitTuple [con_expr, if null bs_needed then d_Expr - else HsVar (last bs_needed)] True + else HsVar (last bs_needed)] Boxed - [lp,rp] = getLRPrecs is_infix fixities dc_nm + [lp,rp] = getLRPrecs is_infix fixity_env dc_nm quals | is_infix = let (h:t) = field_quals in (h:con_qual:t) @@ -916,7 +917,7 @@ gen_Read_binds fixities tycon -} paren_prec_limit | not is_infix = fromInt maxPrecedence - | otherwise = getFixity fixities dc_nm + | otherwise = getFixity fixity_env dc_nm read_paren_arg -- parens depend on precedence... | nullary_con = false_Expr -- it's optional. @@ -930,9 +931,9 @@ gen_Read_binds fixities tycon %************************************************************************ \begin{code} -gen_Show_binds :: Fixities -> TyCon -> RdrNameMonoBinds +gen_Show_binds :: FixityEnv -> TyCon -> RdrNameMonoBinds -gen_Show_binds fixs_assoc tycon +gen_Show_binds fixity_env tycon = shows_prec `AndMonoBinds` show_list where tycon_loc = getSrcLoc tycon @@ -1003,7 +1004,7 @@ gen_Show_binds fixs_assoc tycon mk_showString_app str = HsApp (HsVar showString_RDR) (HsLit (mkHsString str)) - prec_cons = getLRPrecs is_infix fixs_assoc dc_nm + prec_cons = getLRPrecs is_infix fixity_env dc_nm real_show_thingies | is_infix = @@ -1024,27 +1025,27 @@ gen_Show_binds fixs_assoc tycon (map show_label labels) real_show_thingies - (con_left_assoc, con_right_assoc) = isLRAssoc fixs_assoc dc_nm + (con_left_assoc, con_right_assoc) = isLRAssoc fixity_env dc_nm {- c.f. Figure 16 and 17 in Haskell 1.1 report -} paren_prec_limit | not is_infix = fromInt maxPrecedence + 1 - | otherwise = getFixity fixs_assoc dc_nm + 1 + | otherwise = getFixity fixity_env dc_nm + 1 \end{code} \begin{code} -getLRPrecs :: Bool -> Fixities -> Name -> [Integer] -getLRPrecs is_infix fixs_assoc nm = [lp, rp] +getLRPrecs :: Bool -> FixityEnv -> Name -> [Integer] +getLRPrecs is_infix fixity_env nm = [lp, rp] where {- Figuring out the fixities of the arguments to a constructor, cf. Figures 16-18 in Haskell 1.1 report. -} - (con_left_assoc, con_right_assoc) = isLRAssoc fixs_assoc nm - paren_con_prec = getFixity fixs_assoc nm + (con_left_assoc, con_right_assoc) = isLRAssoc fixity_env nm + paren_con_prec = getFixity fixity_env nm maxPrec = fromInt maxPrecedence lp @@ -1057,27 +1058,22 @@ getLRPrecs is_infix fixs_assoc nm = [lp, rp] | con_right_assoc = paren_con_prec | otherwise = paren_con_prec + 1 -getFixity :: Fixities -> Name -> Integer -getFixity fixs_assoc nm = - case lookupFixity fixs_assoc nm of - Fixity x _ -> fromInt x +getFixity :: FixityEnv -> Name -> Integer +getFixity fixity_env nm = case lookupFixity fixity_env nm of + Fixity x _ -> fromInt x -isLRAssoc :: Fixities -> Name -> (Bool, Bool) +isLRAssoc :: FixityEnv -> Name -> (Bool, Bool) isLRAssoc fixs_assoc nm = case lookupFixity fixs_assoc nm of Fixity _ InfixN -> (False, False) Fixity _ InfixR -> (False, True) Fixity _ InfixL -> (True, False) -lookupFixity :: Fixities -> Name -> Fixity -lookupFixity fixs_assoc nm = assocDefault defaultFixity fixs_assoc nm - isInfixOccName :: String -> Bool isInfixOccName str = case str of (':':_) -> True _ -> False - \end{code} @@ -1130,7 +1126,7 @@ gen_tag_n_con_monobind (rdr_name, tycon, GenTag2Con) = mk_FunMonoBind (getSrcLoc tycon) rdr_name [([ConPatIn mkInt_RDR [VarPatIn a_RDR]], ExprWithTySig (HsApp tagToEnum_Expr a_Expr) - (MonoTyVar (qual_orig_name tycon)))] + (HsTyVar (qual_orig_name tycon)))] gen_tag_n_con_monobind (rdr_name, tycon, GenMaxTag) = mk_easy_FunMonoBind (getSrcLoc tycon) diff --git a/ghc/compiler/typecheck/TcHsSyn.lhs b/ghc/compiler/typecheck/TcHsSyn.lhs index e99c01daf5..c45fab7501 100644 --- a/ghc/compiler/typecheck/TcHsSyn.lhs +++ b/ghc/compiler/typecheck/TcHsSyn.lhs @@ -655,15 +655,16 @@ zonkForeignExport (ForeignDecl i imp_exp hs_ty ext_nm cconv src_loc) = zonkRules :: [TcRuleDecl] -> NF_TcM s [TypecheckedRuleDecl] zonkRules rs = mapNF_Tc zonkRule rs -zonkRule (RuleDecl name tyvars vars lhs rhs loc) +zonkRule (HsRule name tyvars vars lhs rhs loc) = mapNF_Tc zonkTcTyVarToTyVar tyvars `thenNF_Tc` \ new_tyvars -> mapNF_Tc zonkIdBndr [v | RuleBndr v <- vars] `thenNF_Tc` \ new_bndrs -> tcExtendGlobalValEnv new_bndrs $ zonkExpr lhs `thenNF_Tc` \ new_lhs -> zonkExpr rhs `thenNF_Tc` \ new_rhs -> - returnNF_Tc (RuleDecl name new_tyvars (map RuleBndr new_bndrs) new_lhs new_rhs loc) + returnNF_Tc (HsRule name new_tyvars (map RuleBndr new_bndrs) new_lhs new_rhs loc) -- I hate this map RuleBndr stuff -zonkRule (IfaceRuleDecl fun rule loc) - = returnNF_Tc (IfaceRuleDecl fun rule loc) +zonkRule (IfaceRuleOut fun rule) + = zonkIdOcc fun `thenNF_Tc` \ fun' -> + returnNF_Tc (IfaceRuleOut fun' rule) \end{code} diff --git a/ghc/compiler/typecheck/TcIfaceSig.lhs b/ghc/compiler/typecheck/TcIfaceSig.lhs index cd5d05cac4..7f803d52c6 100644 --- a/ghc/compiler/typecheck/TcIfaceSig.lhs +++ b/ghc/compiler/typecheck/TcIfaceSig.lhs @@ -8,7 +8,7 @@ module TcIfaceSig ( tcInterfaceSigs, tcVar, tcCoreExpr, tcCoreLamBndrs ) where #include "HsVersions.h" -import HsSyn ( HsDecl(..), IfaceSig(..) ) +import HsSyn ( HsDecl(..), IfaceSig(..), HsTupCon(..) ) import TcMonad import TcMonoType ( tcHsType, tcHsTypeKind, -- NB: all the tyars in interface files are kinded, @@ -39,11 +39,10 @@ import Id ( Id, mkId, mkVanillaId, import MkId ( mkCCallOpId ) import IdInfo import DataCon ( dataConSig, dataConArgTys ) -import Type ( mkSynTy, mkTyVarTys, splitAlgTyConApp, splitFunTys, unUsgTy ) +import Type ( mkSynTy, mkTyVarTys, splitAlgTyConApp, splitAlgTyConApp_maybe, splitFunTys, unUsgTy ) import Var ( mkTyVar, tyVarKind ) import VarEnv import Name ( Name, NamedThing(..), isLocallyDefined ) -import Unique ( rationalTyConKey ) import TysWiredIn ( integerTy, stringTy ) import Demand ( wwLazy ) import ErrUtils ( pprBagOfErrors ) @@ -102,8 +101,8 @@ tcIdInfo unf_env in_scope_vars name ty info info_ins in returnTc info2 - tcPrag info (HsStrictness (HsStrictnessInfo (demands,bot_result))) - = returnTc (info `setStrictnessInfo` StrictnessInfo demands bot_result) + tcPrag info (HsStrictness strict_info) + = returnTc (info `setStrictnessInfo` strict_info) tcPrag info (HsWorker nm) = tcWorkerInfo unf_env ty info nm @@ -214,7 +213,7 @@ tcCoreExpr (UfCCall cc ty) tcGetUnique `thenNF_Tc` \ u -> returnTc (Var (mkCCallOpId u cc ty')) -tcCoreExpr (UfTuple name args) +tcCoreExpr (UfTuple (HsTupCon name _) args) = tcVar name `thenTc` \ con_id -> mapTc tcCoreExpr args `thenTc` \ args' -> let @@ -332,16 +331,18 @@ tcCoreAlt scrut_ty (UfLitLitAlt str ty, names, 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 (UfDataAlt con_name, names, rhs) +tcCoreAlt scrut_ty alt@(UfDataAlt con_name, names, rhs) = tcVar con_name `thenTc` \ con_id -> let - con = case isDataConWrapId_maybe con_id of - Just con -> con - Nothing -> pprPanic "tcCoreAlt" (ppr con_id) + con = case isDataConWrapId_maybe con_id of + Just con -> con + Nothing -> pprPanic "tcCoreAlt" (ppr con_id) (main_tyvars, _, ex_tyvars, _, _, _) = dataConSig con - (_, inst_tys, cons) = splitAlgTyConApp scrut_ty + (_, inst_tys, cons) = case splitAlgTyConApp_maybe scrut_ty of + Just stuff -> stuff + Nothing -> pprPanic "tcCoreAlt" (ppr alt) 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') diff --git a/ghc/compiler/typecheck/TcImprove.lhs b/ghc/compiler/typecheck/TcImprove.lhs index 1451d44027..74f38b997d 100644 --- a/ghc/compiler/typecheck/TcImprove.lhs +++ b/ghc/compiler/typecheck/TcImprove.lhs @@ -4,14 +4,13 @@ module TcImprove ( tcImprove ) where #include "HsVersions.h" import Name ( Name ) -import Type ( Type, tyVarsOfTypes ) -import Class ( className, classInstEnv, classExtraBigSig ) +import Class ( Class, FunDep, className, classInstEnv, classExtraBigSig ) import Unify ( unifyTyListsX, matchTys ) import Subst ( mkSubst, substTy ) import TcMonad -import TcType ( zonkTcType, zonkTcTypes ) +import TcType ( TcType, TcTyVar, TcTyVarSet, zonkTcType, zonkTcTypes ) import TcUnify ( unifyTauTyLists ) -import Inst ( Inst, LookupInstResult(..), +import Inst ( LIE, Inst, LookupInstResult(..), lookupInst, getFunDepsOfLIE, getIPsOfLIE, zonkLIE, zonkFunDeps {- for debugging -} ) import InstEnv ( InstEnv ) -- Reqd for 4.02; InstEnv is a synonym, and @@ -24,65 +23,57 @@ import List ( elemIndex, nub ) \end{code} \begin{code} -tcImprove lie = - if null nfdss then - returnTc () - else - -- zonkCfdss cfdss `thenTc` \ cfdss' -> - -- pprTrace "tcI" (ppr cfdss') $ - iterImprove nfdss - where +tcImprove :: LIE -> TcM s () +-- Do unifications based on functional dependencies in the LIE +tcImprove lie + | null nfdss = returnTc () + | otherwise = iterImprove nfdss + where + nfdss, clas_nfdss, inst_nfdss, ip_nfdss :: [(TcTyVarSet, Name, [FunDep TcType])] + nfdss = ip_nfdss ++ clas_nfdss ++ inst_nfdss + + cfdss :: [(Class, [FunDep TcType])] cfdss = getFunDepsOfLIE lie clas_nfdss = map (\(c, fds) -> (emptyVarSet, className c, fds)) cfdss + classes = nub (map fst cfdss) inst_nfdss = concatMap getInstNfdssOf classes + ips = getIPsOfLIE lie ip_nfdss = map (\(n, ty) -> (emptyVarSet, n, [([], [ty])])) ips - nfdss = ip_nfdss ++ clas_nfdss ++ inst_nfdss -getInstNfdssOf clas = nfdss - where +{- Example: we have + class C a b c | a->b where ... + instance C Int Bool c + + Given the LIE FD C (Int->t) + we get clas_nfdss = [({}, C, [Int->t, t->Int]) + inst_nfdss = [({c}, C, [Int->Bool, Bool->Int])] + + Another way would be to flatten a bit + we get clas_nfdss = [({}, C, Int->t), ({}, C, t->Int)] + inst_nfdss = [({c}, C, Int->Bool), ({c}, C, Bool->Int)] + + iterImprove then matches up the C and Int, and unifies t <-> Bool +-} + +getInstNfdssOf :: Class -> [(TcTyVarSet, Name, [FunDep TcType])] +getInstNfdssOf clas + = [ (free, nm, instantiateFdClassTys clas ts) + | (free, ts, i) <- classInstEnv clas + ] + where nm = className clas - ins = classInstEnv clas - mk_nfds (free, ts, i) = (free, nm, instantiateFdClassTys clas ts) - nfdss = map mk_nfds ins -iterImprove :: [(VarSet, Name, [([Type],[Type])])] -> TcM s () +iterImprove :: [(VarSet, Name, [FunDep TcType])] -> TcM s () iterImprove [] = returnTc () iterImprove cfdss - = -- zonkCfdss cfdss `thenTc` \ cfdss' -> - -- pprTrace "iterI" (ppr cfdss') $ - -- instImprove cfdss `thenTc` \ change1 -> - selfImprove pairImprove cfdss `thenTc` \ change2 -> + = selfImprove pairImprove cfdss `thenTc` \ change2 -> if {- change1 || -} change2 then iterImprove cfdss else returnTc () --- ZZ debugging... -zonkCfdss ((c, fds) : cfdss) - = zonkFunDeps fds `thenTc` \ fds' -> - zonkCfdss cfdss `thenTc` \ cfdss' -> - returnTc ((c, fds') : cfdss') -zonkCfdss [] = returnTc [] - -{- -instImprove (cfds@(clas, fds) : cfdss) - = instImprove1 cfds ins `thenTc` \ changed -> - instImprove cfdss `thenTc` \ rest_changed -> - returnTc (changed || rest_changed) - where ins = classInstEnv clas -instImprove [] = returnTc False - -instImprove1 cfds@(clas, fds1) ((free, ts, i) : ins) - = -- pprTrace "iI1" (ppr (free, ts, i)) $ - checkFds fds1 free fds2 `thenTc` \ changed -> - instImprove1 cfds ins `thenTc` \ rest_changed -> - returnTc (changed || rest_changed) - where fds2 = instantiateFdClassTys clas ts -instImprove1 _ _ = returnTc False --} - -- ZZ this will do a lot of redundant checking wrt instances -- it would do to make this operate over two lists, the first -- with only clas_nfds and ip_nfds, and the second with everything @@ -90,12 +81,13 @@ instImprove1 _ _ = returnTc False -- caller could control whether the redundant inst improvements -- were avoided -- you could then also use this to check for consistency of new instances + +-- selfImprove is really just doing a cartesian product of all the fds selfImprove f [] = returnTc False selfImprove f (nfds : nfdss) = mapTc (f nfds) nfdss `thenTc` \ changes -> - anyTc changes `thenTc` \ changed -> selfImprove f nfdss `thenTc` \ rest_changed -> - returnTc (changed || rest_changed) + returnTc (or changes || rest_changed) pairImprove (free1, n1, fds1) (free2, n2, fds2) = if n1 == n2 then @@ -150,14 +142,6 @@ zonkUnifyTys free ts1 ts2 mapTc zonkTcType ts2 `thenTc` \ ts2' -> -- pprTrace "zMT" (ppr (ts1', free, ts2')) $ case unifyTyListsX free ts2' ts1' of - Just subst {- (subst, []) -} -> -- pprTrace "zMT match!" empty $ - returnTc (Just subst) - Nothing -> returnTc Nothing -\end{code} - -Utilities: - -A monadic version of the standard Prelude `or' function. -\begin{code} -anyTc bs = foldrTc (\a b -> returnTc (a || b)) False bs + Just subst -> returnTc (Just subst) + Nothing -> returnTc Nothing \end{code} diff --git a/ghc/compiler/typecheck/TcInstDcls.lhs b/ghc/compiler/typecheck/TcInstDcls.lhs index 882123f387..a140b9c832 100644 --- a/ghc/compiler/typecheck/TcInstDcls.lhs +++ b/ghc/compiler/typecheck/TcInstDcls.lhs @@ -19,7 +19,7 @@ import TcHsSyn ( TcMonoBinds, mkHsConApp ) import TcBinds ( tcSpecSigs ) import TcClassDcl ( tcMethodBind, checkFromThisClass ) import TcMonad -import RnMonad ( RnNameSupply, Fixities ) +import RnMonad ( RnNameSupply, FixityEnv ) import Inst ( Inst, InstOrigin(..), newDicts, newClassDicts, LIE, emptyLIE, plusLIE, plusLIEs ) @@ -59,7 +59,7 @@ import Subst ( mkTopTyVarSubst, substClasses ) import VarSet ( mkVarSet, varSetElems ) import TysPrim ( byteArrayPrimTyCon, mutableByteArrayPrimTyCon ) import TysWiredIn ( stringTy, isFFIArgumentTy, isFFIResultTy ) -import Unique ( Unique, cCallableClassKey, cReturnableClassKey, Uniquable(..) ) +import Unique ( Unique, cCallableClassKey, cReturnableClassKey, hasKey, Uniquable(..) ) import Outputable \end{code} @@ -140,7 +140,7 @@ and $dbinds_super$ bind the superclass dictionaries sd1 \ldots sdm. tcInstDecls1 :: ValueEnv -- Contains IdInfo for dfun ids -> [RenamedHsDecl] -> ModuleName -- module name for deriving - -> Fixities + -> FixityEnv -> RnNameSupply -- for renaming derivings -> TcM s (Bag InstInfo, RenamedHsBinds) @@ -492,8 +492,8 @@ scrutiniseInstanceHead clas inst_taus | -- CCALL CHECK -- A user declaration of a CCallable/CReturnable instance -- must be for a "boxed primitive" type. - (getUnique clas == cCallableClassKey && not (ccallable_type first_inst_tau)) || - (getUnique clas == cReturnableClassKey && not (creturnable_type first_inst_tau)) + (clas `hasKey` cCallableClassKey && not (ccallable_type first_inst_tau)) || + (clas `hasKey` cReturnableClassKey && not (creturnable_type first_inst_tau)) = addErrTc (nonBoxedPrimCCallErr clas first_inst_tau) -- DERIVING CHECK diff --git a/ghc/compiler/typecheck/TcModule.lhs b/ghc/compiler/typecheck/TcModule.lhs index 14adb46edc..e21730a3be 100644 --- a/ghc/compiler/typecheck/TcModule.lhs +++ b/ghc/compiler/typecheck/TcModule.lhs @@ -13,6 +13,7 @@ module TcModule ( import CmdLineOpts ( opt_D_dump_tc, opt_D_dump_types, opt_PprStyle_Debug ) import HsSyn ( HsModule(..), HsBinds(..), MonoBinds(..), HsDecl(..) ) +import HsTypes ( toHsType ) import RnHsSyn ( RenamedHsModule ) import TcHsSyn ( TcMonoBinds, TypecheckedMonoBinds, TypecheckedForeignDecl, TypecheckedRuleDecl, @@ -25,9 +26,9 @@ import TcBinds ( tcTopBindsAndThen ) import TcClassDcl ( tcClassDecls2, mkImplicitClassBinds ) import TcDefaults ( tcDefaults ) import TcEnv ( tcExtendGlobalValEnv, tcExtendTypeEnv, - getEnvTyCons, getEnvClasses, tcLookupValueMaybe, + getEnvTyCons, getEnvClasses, tcLookupValueByKeyMaybe, explicitLookupValueByKey, tcSetValueEnv, - tcLookupTyCon, initEnv, valueEnvIds, + initEnv, ValueEnv, TcTyThing(..) ) import TcExpr ( tcId ) @@ -44,24 +45,23 @@ import TcType ( TcType, typeToTcType, newTyVarTy ) -import RnMonad ( RnNameSupply, getIfaceFixities, Fixities, InterfaceDetails ) +import RnMonad ( RnNameSupply, FixityEnv ) import Bag ( isEmptyBag ) import ErrUtils ( Message, printErrorsAndWarnings, dumpIfSet ) -import Id ( Id, idType ) +import Id ( Id, idType, idName ) import Module ( pprModuleName ) import OccName ( isSysOcc ) import Name ( Name, nameUnique, nameOccName, isLocallyDefined, - toRdrName, NamedThing(..) + toRdrName, nameEnvElts, NamedThing(..) ) import TyCon ( TyCon, tyConKind ) import Class ( Class, classSelIds, classTyCon ) import Type ( mkTyConApp, mkForAllTy, boxedTypeKind, getTyVar, Type ) import TysWiredIn ( unitTy ) -import PrelMods ( mAIN_Name ) -import PrelInfo ( main_NAME, thinAirIdNames, setThinAirIds ) +import PrelInfo ( mAIN_Name ) import TcUnify ( unifyTauTy ) -import Unique ( Unique ) +import Unique ( Unique, mainKey ) import UniqSupply ( UniqSupply ) import Maybes ( maybeToBool ) import Util @@ -83,33 +83,26 @@ data TcResults tc_insts :: Bag InstInfo, -- Instance declaration information tc_fords :: [TypecheckedForeignDecl], -- Foreign import & exports. tc_rules :: [TypecheckedRuleDecl], -- Transformation rules - tc_env :: ValueEnv, - tc_thinair :: [Id] -- The thin-air Ids + tc_env :: ValueEnv } --------------- typecheckModule :: UniqSupply -> RnNameSupply - -> InterfaceDetails + -> FixityEnv -> RenamedHsModule -> IO (Maybe TcResults) -typecheckModule us rn_name_supply iface_det mod - = initTc us initEnv (tcModule rn_name_supply (getIfaceFixities iface_det) mod) - >>= \ (maybe_result, warns, errs) -> +typecheckModule us rn_name_supply fixity_env mod + = initTc us initEnv (tcModule rn_name_supply fixity_env mod) >>= \ (maybe_result, warns, errs) -> printErrorsAndWarnings errs warns >> - - -- write the thin-air Id map - (case maybe_result of - Just results -> setThinAirIds (tc_thinair results) - Nothing -> return () - ) >> - + (case maybe_result of Nothing -> return () - Just results -> dumpIfSet opt_D_dump_tc "Typechecked" (dump_tc results) + Just results -> dumpIfSet opt_D_dump_types "Type signatures" (dump_sigs results) >> + dumpIfSet opt_D_dump_tc "Typechecked" (dump_tc results) ) >> return (if isEmptyBag errs then @@ -120,6 +113,22 @@ typecheckModule us rn_name_supply iface_det mod dump_tc results = ppr (tc_binds results) $$ pp_rules (tc_rules results) +dump_sigs results -- 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 $ + [(toRdrName id, toHsType (idType id)) | id <- nameEnvElts (tc_env results), + want_sig id + ] + where + lt_sig (n1,_) (n2,_) = n1 < n2 + ppr_sig (n,t) = ppr n <+> dcolon <+> ppr t + + want_sig id | opt_PprStyle_Debug = True + | otherwise = isLocallyDefined n && not (isSysOcc (nameOccName n)) + where + n = idName id + pp_rules [] = empty pp_rules rs = vcat [ptext SLIT("{-# RULES"), nest 4 (vcat (map ppr rs)), @@ -129,12 +138,12 @@ pp_rules rs = vcat [ptext SLIT("{-# RULES"), The internal monster: \begin{code} tcModule :: RnNameSupply -- for renaming derivings - -> Fixities -- needed for Show/Read derivings. + -> FixityEnv -- needed for Show/Read derivings. -> RenamedHsModule -- input -> TcM s TcResults -- output tcModule rn_name_supply fixities - (HsModule mod_name verion exports imports decls _ src_loc) + (HsModule mod_name _ _ _ decls _ src_loc) = tcAddSrcLoc src_loc $ -- record where we're starting fixTc (\ ~(unf_env ,_) -> @@ -165,22 +174,42 @@ tcModule rn_name_supply fixities ) `thenTc` \ (_, env, inst_info, deriv_binds) -> tcSetEnv env ( + let + tycons = getEnvTyCons env + classes = getEnvClasses env + local_tycons = filter isLocallyDefined tycons + local_classes = filter isLocallyDefined classes + in -- Default declarations tcDefaults decls `thenTc` \ defaulting_tys -> tcSetDefaultTys defaulting_tys $ + -- Extend the TyCon envt with the tycons corresponding to + -- the classes. + -- They are mentioned in types in interface files. + tcExtendTypeEnv [ (getName tycon, (kindToTcKind (tyConKind tycon), ADataTyCon tycon)) + | clas <- classes, + let tycon = classTyCon clas + ] $ + + -- Interface type signatures + -- 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 + -- We must do this before mkImplicitDataBinds (which comes next), since + -- the latter looks up unpackCStringId, for example, which is usually + -- imported + tcInterfaceSigs unf_env decls `thenTc` \ sig_ids -> + tcExtendGlobalValEnv sig_ids $ + -- Create any necessary record selector Ids and their bindings -- "Necessary" includes data and newtype declarations -- We don't create bindings for dictionary constructors; -- they are always fully applied, and the bindings are just there -- to support partial applications - let - tycons = getEnvTyCons env - classes = getEnvClasses env - local_tycons = filter isLocallyDefined tycons - local_classes = filter isLocallyDefined classes - in mkImplicitDataBinds tycons `thenTc` \ (data_ids, imp_data_binds) -> mkImplicitClassBinds classes `thenNF_Tc` \ (cls_ids, imp_cls_binds) -> @@ -194,23 +223,6 @@ tcModule rn_name_supply fixities tcExtendGlobalValEnv data_ids $ tcExtendGlobalValEnv cls_ids $ - -- Extend the TyCon envt with the tycons corresponding to - -- the classes. - -- They are mentioned in types in interface files. - tcExtendTypeEnv [ (getName tycon, (kindToTcKind (tyConKind tycon), Nothing, ATyCon tycon)) - | clas <- classes, - let tycon = classTyCon clas - ] $ - - -- Interface type signatures - -- 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 - tcInterfaceSigs unf_env decls `thenTc` \ sig_ids -> - tcExtendGlobalValEnv sig_ids $ - -- foreign import declarations next. tcForeignImports decls `thenTc` \ (fo_ids, foi_decls) -> tcExtendGlobalValEnv fo_ids $ @@ -253,7 +265,7 @@ tcModule rn_name_supply fixities -- Check that Main defines main (if mod_name == mAIN_Name then - tcLookupValueMaybe main_NAME `thenNF_Tc` \ maybe_main -> + tcLookupValueByKeyMaybe mainKey `thenNF_Tc` \ maybe_main -> checkTc (maybeToBool maybe_main) noMainErr else returnTc () @@ -275,12 +287,6 @@ tcModule rn_name_supply fixities zonkForeignExports foe_decls `thenNF_Tc` \ foe_decls' -> zonkRules rules `thenNF_Tc` \ rules' -> - let - thin_air_ids = map (explicitLookupValueByKey really_final_env . nameUnique) thinAirIdNames - -- When looking up the thin-air names we must use - -- a global env that includes the zonked locally-defined Ids too - -- Hence using really_final_env - in returnTc (really_final_env, (TcResults { tc_binds = all_binds', tc_tycons = local_tycons, @@ -288,8 +294,7 @@ tcModule rn_name_supply fixities tc_insts = inst_info, tc_fords = foi_decls ++ foe_decls', tc_rules = rules', - tc_env = really_final_env, - tc_thinair = thin_air_ids + tc_env = really_final_env })) ) @@ -304,6 +309,6 @@ get_val_decls decls = foldr ThenBinds EmptyBinds [binds | ValD binds <- decls] \begin{code} noMainErr = hsep [ptext SLIT("Module"), quotes (pprModuleName mAIN_Name), - ptext SLIT("must include a definition for"), quotes (ppr main_NAME)] + ptext SLIT("must include a definition for"), quotes (ptext SLIT("main"))] \end{code} diff --git a/ghc/compiler/typecheck/TcMonoType.lhs b/ghc/compiler/typecheck/TcMonoType.lhs index 2745f78a6c..cb6c3be3e6 100644 --- a/ghc/compiler/typecheck/TcMonoType.lhs +++ b/ghc/compiler/typecheck/TcMonoType.lhs @@ -13,8 +13,8 @@ module TcMonoType ( tcHsType, tcHsSigType, tcHsTypeKind, tcHsTopType, tcHsTopBox #include "HsVersions.h" -import HsSyn ( HsType(..), HsTyVar(..), MonoUsageAnn(..), - Sig(..), HsPred(..), pprHsPred, pprParendHsType ) +import HsSyn ( HsType(..), HsTyVarBndr(..), HsUsageAnn(..), + Sig(..), HsPred(..), pprParendHsType, HsTupCon(..) ) import RnHsSyn ( RenamedHsType, RenamedContext, RenamedSig ) import TcHsSyn ( TcId ) @@ -48,14 +48,14 @@ import VarEnv import VarSet import Bag ( bagToList ) import ErrUtils ( Message ) -import PrelInfo ( cCallishClassKeys ) import TyCon ( TyCon ) import Name ( Name, OccName, isLocallyDefined ) -import TysWiredIn ( mkListTy, mkTupleTy, mkUnboxedTupleTy ) +import TysWiredIn ( mkListTy, mkTupleTy ) import UniqFM ( elemUFM, foldUFM ) +import BasicTypes ( Boxity(..) ) import SrcLoc ( SrcLoc ) import Unique ( Unique, Uniquable(..) ) -import Util ( mapAccumL, isSingleton ) +import Util ( mapAccumL, isSingleton, removeDups ) import Outputable \end{code} @@ -153,49 +153,45 @@ tc_type ty returnTc tc_ty tc_type_kind :: RenamedHsType -> TcM s (TcKind, Type) -tc_type_kind ty@(MonoTyVar name) +tc_type_kind ty@(HsTyVar name) = tc_app ty [] -tc_type_kind (MonoListTy ty) +tc_type_kind (HsListTy ty) = tc_boxed_type ty `thenTc` \ tau_ty -> returnTc (boxedTypeKind, mkListTy tau_ty) -tc_type_kind (MonoTupleTy tys True {-boxed-}) +tc_type_kind (HsTupleTy (HsTupCon _ Boxed) tys) = mapTc tc_boxed_type tys `thenTc` \ tau_tys -> - returnTc (boxedTypeKind, mkTupleTy (length tys) tau_tys) + returnTc (boxedTypeKind, mkTupleTy Boxed (length tys) tau_tys) -tc_type_kind (MonoTupleTy tys False {-unboxed-}) +tc_type_kind (HsTupleTy (HsTupCon _ Unboxed) tys) = mapTc tc_type tys `thenTc` \ tau_tys -> - returnTc (unboxedTypeKind, mkUnboxedTupleTy (length tys) tau_tys) + returnTc (unboxedTypeKind, mkTupleTy Unboxed (length tys) tau_tys) -tc_type_kind (MonoFunTy ty1 ty2) +tc_type_kind (HsFunTy ty1 ty2) = tc_type ty1 `thenTc` \ tau_ty1 -> tc_type ty2 `thenTc` \ tau_ty2 -> returnTc (boxedTypeKind, mkFunTy tau_ty1 tau_ty2) -tc_type_kind (MonoTyApp ty1 ty2) +tc_type_kind (HsAppTy ty1 ty2) = tc_app ty1 [ty2] -tc_type_kind (MonoIParamTy n ty) - = tc_type ty `thenTc` \ tau -> - returnTc (boxedTypeKind, mkPredTy (IParam n tau)) +tc_type_kind (HsPredTy pred) + = tcClassAssertion True pred `thenTc` \ pred' -> + returnTc (boxedTypeKind, mkPredTy pred') -tc_type_kind (MonoDictTy class_name tys) - = tcClassAssertion (HsPClass class_name tys) `thenTc` \ (Class clas arg_tys) -> - returnTc (boxedTypeKind, mkDictTy clas arg_tys) - -tc_type_kind (MonoUsgTy usg ty) +tc_type_kind (HsUsgTy usg ty) = newUsg usg `thenTc` \ usg' -> tc_type_kind ty `thenTc` \ (kind, tc_ty) -> returnTc (kind, mkUsgTy usg' tc_ty) where newUsg usg = case usg of - MonoUsOnce -> returnTc UsOnce - MonoUsMany -> returnTc UsMany - MonoUsVar uv_name -> tcLookupUVar uv_name `thenTc` \ uv -> + HsUsOnce -> returnTc UsOnce + HsUsMany -> returnTc UsMany + HsUsVar uv_name -> tcLookupUVar uv_name `thenTc` \ uv -> returnTc (UsVar uv) -tc_type_kind (MonoUsgForAllTy uv_name ty) +tc_type_kind (HsUsgForAllTy uv_name ty) = let uv = mkNamedUVar uv_name in @@ -217,12 +213,12 @@ tc_type_kind (HsForAllTy (Just tv_names) context ty) -- f :: forall a. Num a => (# a->a, a->a #) -- And we want these to get through the type checker check ct@(Class c tys) | ambiguous = failWithTc (ambigErr (c,tys) tau) - where ct_vars = tyVarsOfTypes tys + where ct_vars = tyVarsOfTypes tys forall_tyvars = map varName in_scope_vars - tau_vars = tyVarsOfType tau - ambig ct_var = (varName ct_var `elem` forall_tyvars) && - not (ct_var `elemUFM` tau_vars) - ambiguous = foldUFM ((||) . ambig) False ct_vars + tau_vars = tyVarsOfType tau + ambig ct_var = (varName ct_var `elem` forall_tyvars) && + not (ct_var `elemUFM` tau_vars) + ambiguous = foldUFM ((||) . ambig) False ct_vars check _ = returnTc () in mapTc check theta `thenTc_` @@ -233,7 +229,7 @@ Help functions for type applications ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ \begin{code} -tc_app (MonoTyApp ty1 ty2) tys +tc_app (HsAppTy ty1 ty2) tys = tc_app ty1 (ty2:tys) tc_app ty tys @@ -257,16 +253,16 @@ tc_app ty tys -- But not quite; for synonyms it checks the correct arity, and builds a SynTy -- hence the rather strange functionality. -tc_fun_type (MonoTyVar name) arg_tys - = tcLookupTy name `thenTc` \ (tycon_kind, maybe_arity, thing) -> +tc_fun_type (HsTyVar name) arg_tys + = tcLookupTy name `thenTc` \ (tycon_kind, thing) -> case thing of - ATyVar tv -> returnTc (tycon_kind, mkAppTys (mkTyVarTy tv) arg_tys) - AClass clas -> failWithTc (classAsTyConErr name) - ATyCon tc -> case maybe_arity of - Nothing -> -- Data or newtype - returnTc (tycon_kind, mkTyConApp tc arg_tys) + ATyVar tv -> returnTc (tycon_kind, mkAppTys (mkTyVarTy tv) arg_tys) + AClass clas _ -> failWithTc (classAsTyConErr name) + + ADataTyCon tc -> -- Data or newtype + returnTc (tycon_kind, mkTyConApp tc arg_tys) - Just arity -> -- Type synonym + ASynTyCon tc arity -> -- Type synonym checkTc (arity <= n_args) err_msg `thenTc_` returnTc (tycon_kind, result_ty) where @@ -290,35 +286,14 @@ Contexts \begin{code} tcContext :: RenamedContext -> TcM s ThetaType -tcContext context - = --Someone discovered that @CCallable@ and @CReturnable@ - -- could be used in contexts such as: - -- foo :: CCallable a => a -> PrimIO Int - -- Doing this utterly wrecks the whole point of introducing these - -- classes so we specifically check that this isn't being done. - -- - -- We *don't* do this check in tcClassAssertion, because that's - -- called when checking a HsDictTy, and we don't want to reject - -- instance CCallable Int - -- etc. Ugh! - mapTc check_naughty context `thenTc_` - - mapTc tcClassAssertion context - - where - check_naughty (HsPClass class_name _) - = checkTc (not (getUnique class_name `elem` cCallishClassKeys)) - (naughtyCCallContextErr class_name) - check_naughty (HsPIParam _ _) = returnTc () - -tcClassAssertion assn@(HsPClass class_name tys) - = tcAddErrCtxt (appKindCtxt (pprHsPred assn)) $ - mapAndUnzipTc tc_type_kind tys `thenTc` \ (arg_kinds, arg_tys) -> - tcLookupTy class_name `thenTc` \ (kind, ~(Just arity), thing) -> +tcContext context = mapTc (tcClassAssertion False) context + +tcClassAssertion ccall_ok assn@(HsPClass class_name tys) + = tcAddErrCtxt (appKindCtxt (ppr assn)) $ + mapAndUnzipTc tc_type_kind tys `thenTc` \ (arg_kinds, arg_tys) -> + tcLookupTy class_name `thenTc` \ (kind, thing) -> case thing of - ATyVar _ -> failWithTc (tyVarAsClassErr class_name) - ATyCon _ -> failWithTc (tyConAsClassErr class_name) - AClass clas -> + AClass clas arity -> -- Check with kind mis-match checkTc (arity == n_tys) err `thenTc_` unifyKind kind (mkArrowKinds arg_kinds boxedTypeKind) `thenTc_` @@ -326,8 +301,10 @@ tcClassAssertion assn@(HsPClass class_name tys) where n_tys = length tys err = arityErr "Class" class_name arity n_tys -tcClassAssertion assn@(HsPIParam name ty) - = tcAddErrCtxt (appKindCtxt (pprHsPred assn)) $ + other -> failWithTc (tyVarAsClassErr class_name) + +tcClassAssertion ccall_ok assn@(HsPIParam name ty) + = tcAddErrCtxt (appKindCtxt (ppr assn)) $ tc_type_kind ty `thenTc` \ (arg_kind, arg_ty) -> returnTc (IParam name arg_ty) \end{code} @@ -340,7 +317,7 @@ tcClassAssertion assn@(HsPIParam name ty) %************************************************************************ \begin{code} -tcExtendTopTyVarScope :: TcKind -> [HsTyVar Name] +tcExtendTopTyVarScope :: TcKind -> [HsTyVarBndr Name] -> ([TcTyVar] -> TcKind -> TcM s a) -> TcM s a tcExtendTopTyVarScope kind tyvar_names thing_inside @@ -354,14 +331,14 @@ tcExtendTopTyVarScope kind tyvar_names thing_inside mk_tv (IfaceTyVar name _, kind) = mkTyVar name kind -- NB: immutable tyvars, but perhaps with mutable kinds -tcExtendTyVarScope :: [HsTyVar Name] +tcExtendTyVarScope :: [HsTyVarBndr Name] -> ([TcTyVar] -> TcM s a) -> TcM s a tcExtendTyVarScope tv_names thing_inside = mapNF_Tc tcHsTyVar tv_names `thenNF_Tc` \ tyvars -> tcExtendTyVarEnv tyvars $ thing_inside tyvars -tcHsTyVar :: HsTyVar Name -> NF_TcM s TcTyVar +tcHsTyVar :: HsTyVarBndr Name -> NF_TcM s TcTyVar tcHsTyVar (UserTyVar name) = newKindVar `thenNF_Tc` \ kind -> tcNewMutTyVar name kind -- NB: mutable kind => mutable tyvar, so that zonking can bind @@ -369,7 +346,7 @@ tcHsTyVar (UserTyVar name) = newKindVar `thenNF_Tc` \ kind -> tcHsTyVar (IfaceTyVar name kind) = returnNF_Tc (mkTyVar name (kindToTcKind kind)) -kcHsTyVar :: HsTyVar name -> NF_TcM s TcKind +kcHsTyVar :: HsTyVarBndr name -> NF_TcM s TcKind kcHsTyVar (UserTyVar name) = newKindVar kcHsTyVar (IfaceTyVar name kind) = returnNF_Tc (kindToTcKind kind) \end{code} @@ -716,10 +693,6 @@ sigPatCtxt bound_tvs bound_ids tidy_env %************************************************************************ \begin{code} -naughtyCCallContextErr clas_name - = sep [ptext SLIT("Can't use class") <+> quotes (ppr clas_name), - ptext SLIT("in a context")] - typeCtxt ty = ptext SLIT("In the type") <+> quotes (ppr ty) typeKindCtxt :: RenamedHsType -> Message @@ -742,5 +715,5 @@ tyVarAsClassErr name ambigErr (c, ts) ty = sep [ptext SLIT("Ambiguous constraint") <+> quotes (pprConstraint c ts), nest 4 (ptext SLIT("for the type:") <+> ppr ty), - nest 4 (ptext SLIT("Each forall'd type variable mentioned by the constraint must appear after the =>."))] + nest 4 (ptext SLIT("Each forall'd type variable mentioned by the constraint must appear after the =>"))] \end{code} diff --git a/ghc/compiler/typecheck/TcPat.lhs b/ghc/compiler/typecheck/TcPat.lhs index e193c7eada..f5045e409b 100644 --- a/ghc/compiler/typecheck/TcPat.lhs +++ b/ghc/compiler/typecheck/TcPat.lhs @@ -26,11 +26,8 @@ import TcEnv ( tcLookupValue, tcLookupClassByKey, ) import TcType ( TcType, TcTyVar, tcInstTyVars, newTyVarTy ) import TcMonoType ( tcHsSigType ) -import TcUnify ( unifyTauTy, unifyListTy, - unifyTupleTy, unifyUnboxedTupleTy - ) +import TcUnify ( unifyTauTy, unifyListTy, unifyTupleTy ) -import Bag ( Bag ) import CmdLineOpts ( opt_IrrefutableTuples ) import DataCon ( DataCon, dataConSig, dataConFieldLabels, dataConSourceArity @@ -47,6 +44,7 @@ import SrcLoc ( SrcLoc ) import Unique ( eqClassOpKey, geClassOpKey, minusClassOpKey, cCallableClassKey ) +import BasicTypes ( isBoxed ) import Bag import Util ( zipEqual ) import Outputable @@ -166,18 +164,15 @@ tcPat tc_bndr pat_in@(ListPatIn pats) pat_ty tcPats tc_bndr pats (repeat elem_ty) `thenTc` \ (pats', lie_req, tvs, ids, lie_avail) -> returnTc (ListPat elem_ty pats', lie_req, tvs, ids, lie_avail) -tcPat tc_bndr pat_in@(TuplePatIn pats boxed) pat_ty +tcPat tc_bndr pat_in@(TuplePatIn pats boxity) pat_ty = tcAddErrCtxt (patCtxt pat_in) $ - (if boxed - then unifyTupleTy arity pat_ty - else unifyUnboxedTupleTy arity pat_ty) `thenTc` \ arg_tys -> - - tcPats tc_bndr pats arg_tys `thenTc` \ (pats', lie_req, tvs, ids, lie_avail) -> + unifyTupleTy boxity arity pat_ty `thenTc` \ arg_tys -> + tcPats tc_bndr pats arg_tys `thenTc` \ (pats', lie_req, tvs, ids, lie_avail) -> -- possibly do the "make all tuple-pats irrefutable" test: let - unmangled_result = TuplePat pats' boxed + unmangled_result = TuplePat pats' boxity -- Under flag control turn a pattern (x,y,z) into ~(x,y,z) -- so that we can experiment with lazy tuple-matching. @@ -185,8 +180,8 @@ tcPat tc_bndr pat_in@(TuplePatIn pats boxed) pat_ty -- it was easy to do. possibly_mangled_result - | opt_IrrefutableTuples && boxed = LazyPat unmangled_result - | otherwise = unmangled_result + | opt_IrrefutableTuples && isBoxed boxity = LazyPat unmangled_result + | otherwise = unmangled_result in returnTc (possibly_mangled_result, lie_req, tvs, ids, lie_avail) where diff --git a/ghc/compiler/typecheck/TcRules.lhs b/ghc/compiler/typecheck/TcRules.lhs index 262ba38cb4..616d717b7f 100644 --- a/ghc/compiler/typecheck/TcRules.lhs +++ b/ghc/compiler/typecheck/TcRules.lhs @@ -8,8 +8,8 @@ module TcRules ( tcRules ) where #include "HsVersions.h" -import HsSyn ( HsDecl(..), RuleDecl(..), RuleBndr(..), HsTyVar(..) ) -import HsCore ( UfRuleBody(..) ) +import HsSyn ( HsDecl(..), RuleDecl(..), RuleBndr(..), HsTyVarBndr(..) ) +import CoreSyn ( CoreRule(..) ) import RnHsSyn ( RenamedHsDecl ) import TcHsSyn ( TypecheckedRuleDecl, mkHsLet ) import TcMonad @@ -35,16 +35,20 @@ tcRules :: [RenamedHsDecl] -> TcM s (LIE, [TypecheckedRuleDecl]) tcRules decls = mapAndUnzipTc tcRule [rule | RuleD rule <- decls] `thenTc` \ (lies, rules) -> returnTc (plusLIEs lies, rules) -tcRule (IfaceRuleDecl fun (UfRuleBody name vars args rhs) src_loc) +tcRule (IfaceRule name vars fun args rhs src_loc) = tcAddSrcLoc src_loc $ tcAddErrCtxt (ruleCtxt name) $ tcVar fun `thenTc` \ fun' -> tcCoreLamBndrs vars $ \ vars' -> mapTc tcCoreExpr args `thenTc` \ args' -> tcCoreExpr rhs `thenTc` \ rhs' -> - returnTc (emptyLIE, IfaceRuleDecl fun' (CoreRuleBody name vars' args' rhs') src_loc) + returnTc (emptyLIE, IfaceRuleOut fun' (Rule name vars' args' rhs')) -tcRule (RuleDecl name sig_tvs vars lhs rhs src_loc) +tcRule (IfaceRuleOut fun rule) + = tcVar fun `thenTc` \ fun' -> + returnTc (emptyLIE, IfaceRuleOut fun' rule) + +tcRule (HsRule name sig_tvs vars lhs rhs src_loc) = tcAddSrcLoc src_loc $ tcAddErrCtxt (ruleCtxt name) $ newTyVarTy_OpenKind `thenNF_Tc` \ rule_ty -> @@ -96,7 +100,7 @@ tcRule (RuleDecl name sig_tvs vars lhs rhs src_loc) tcSimplifyAndCheck (text "tcRule") tpl_tvs lhs_dicts rhs_lie `thenTc` \ (lie', rhs_binds) -> - returnTc (lie', RuleDecl name (varSetElems tpl_tvs) + returnTc (lie', HsRule name (varSetElems tpl_tvs) (map RuleBndr tpl_ids) -- yuk (mkHsLet lhs_binds lhs') (mkHsLet rhs_binds rhs') diff --git a/ghc/compiler/typecheck/TcTyClsDecls.lhs b/ghc/compiler/typecheck/TcTyClsDecls.lhs index b24673a70e..bdf1488e57 100644 --- a/ghc/compiler/typecheck/TcTyClsDecls.lhs +++ b/ghc/compiler/typecheck/TcTyClsDecls.lhs @@ -11,19 +11,19 @@ module TcTyClsDecls ( #include "HsVersions.h" import HsSyn ( HsDecl(..), TyClDecl(..), - HsType(..), HsTyVar, + HsType(..), HsTyVarBndr, ConDecl(..), ConDetails(..), BangType(..), - Sig(..), HsPred(..), + Sig(..), HsPred(..), HsTupCon(..), tyClDeclName, isClassDecl, isSynDecl ) -import RnHsSyn ( RenamedHsDecl, RenamedTyClDecl, listTyCon_name, tupleTyCon_name ) +import RnHsSyn ( RenamedHsDecl, RenamedTyClDecl, listTyCon_name ) import BasicTypes ( RecFlag(..), NewOrData(..), Arity ) import TcMonad import Inst ( InstanceMapper ) import TcClassDcl ( kcClassDecl, tcClassDecl1 ) import TcEnv ( ValueEnv, TcTyThing(..), - tcExtendTypeEnv, getAllEnvTyCons + tcExtendTypeEnv, getEnvAllTyCons ) import TcTyDecls ( tcTyDecl, kcTyDecl ) import TcMonoType ( kcHsTyVar ) @@ -87,9 +87,11 @@ tcGroup unf_env inst_mapper scc -- Tie the knot -- traceTc (ppr (map fst ty_env_stuff1)) `thenTc_` - fixTc ( \ ~(rec_tyclss, rec_vrcs, _) -> + fixTc ( \ ~(rec_tyclss, _) -> let - rec_env = listToUFM rec_tyclss + rec_env = listToUFM rec_tyclss + rec_tycons = getEnvAllTyCons rec_tyclss + rec_vrcs = calcTyConArgVrcs rec_tycons in -- Do type checking @@ -99,13 +101,8 @@ tcGroup unf_env inst_mapper scc `thenTc` \ tyclss -> tcGetEnv `thenTc` \ env -> - let - tycons = getAllEnvTyCons env - vrcs = calcTyConArgVrcs tycons - in - - returnTc (tyclss, vrcs, env) - ) `thenTc` \ (_, _, env) -> + returnTc (tyclss, env) + ) `thenTc` \ (_, env) -> -- traceTc (text "done" <+> ppr (map fst ty_env_stuff1)) `thenTc_` returnTc env where @@ -135,11 +132,9 @@ tcDecl :: RecFlag -- True => recursive group tcDecl is_rec_group unf_env inst_mapper vrcs_env decl = tcAddDeclCtxt decl $ if isClassDecl decl then - tcClassDecl1 unf_env inst_mapper vrcs_env decl `thenTc` \ clas -> - returnTc (getName clas, AClass clas) + tcClassDecl1 unf_env inst_mapper vrcs_env decl else - tcTyDecl is_rec_group vrcs_env decl `thenTc` \ tycon -> - returnTc (getName tycon, ATyCon tycon) + tcTyDecl is_rec_group vrcs_env decl tcAddDeclCtxt decl thing_inside @@ -150,9 +145,9 @@ tcAddDeclCtxt decl thing_inside (name, loc, thing) = case decl of (ClassDecl _ name _ _ _ _ _ _ _ _ _ loc) -> (name, loc, "class") - (TySynonym name _ _ loc) -> (name, loc, "type synonym") - (TyData NewType _ name _ _ _ _ loc) -> (name, loc, "data type") - (TyData DataType _ name _ _ _ _ loc) -> (name, loc, "newtype") + (TySynonym name _ _ loc) -> (name, loc, "type synonym") + (TyData NewType _ name _ _ _ _ _ loc) -> (name, loc, "data type") + (TyData DataType _ name _ _ _ _ _ loc) -> (name, loc, "newtype") ctxt = hsep [ptext SLIT("In the"), text thing, ptext SLIT("declaration for"), quotes (ppr name)] @@ -169,7 +164,7 @@ bound in type, data, newtype and class declarations, Why do we need to grab all these type variables at once, including those locally-quantified type variables in class op signatures? - [Incidentally, this only works because the names are all unique by now.] + [Incidentally, this only works because the names are all unique by now.] Because we can only commit to the final kind of a type variable when we've completed the mutually recursive group. For example: @@ -184,36 +179,35 @@ Here, the kind of the locally-polymorphic type variable "b" 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. + [April 00: looks as if we've dropped this subtlety; I'm not sure when] \begin{code} -getTyBinding1 :: RenamedTyClDecl -> NF_TcM s (Name, (TcKind, Maybe Arity, TcTyThing)) +getTyBinding1 :: RenamedTyClDecl -> NF_TcM s (Name, (TcKind, TcTyThing)) getTyBinding1 (TySynonym name tyvars _ _) = mapNF_Tc kcHsTyVar tyvars `thenNF_Tc` \ arg_kinds -> newKindVar `thenNF_Tc` \ result_kind -> returnNF_Tc (name, (foldr mkArrowKind result_kind arg_kinds, - Just (length tyvars), - ATyCon (pprPanic "ATyCon: syn" (ppr name)))) + ASynTyCon (pprPanic "ATyCon: syn" (ppr name)) (length tyvars))) -getTyBinding1 (TyData _ _ name tyvars _ _ _ _) +getTyBinding1 (TyData _ _ name tyvars _ _ _ _ _) = mapNF_Tc kcHsTyVar tyvars `thenNF_Tc` \ arg_kinds -> returnNF_Tc (name, (foldr mkArrowKind boxedTypeKind arg_kinds, - Nothing, - ATyCon (error "ATyCon: data"))) + ADataTyCon (error "ATyCon: data"))) getTyBinding1 (ClassDecl _ name tyvars _ _ _ _ _ _ _ _ _) = mapNF_Tc kcHsTyVar tyvars `thenNF_Tc` \ arg_kinds -> returnNF_Tc (name, (foldr mkArrowKind boxedTypeKind arg_kinds, - Just (length tyvars), - AClass (error "AClass"))) + AClass (pprPanic "AClass" (ppr name)) (length tyvars))) -- Zonk the kind to its final form, and lookup the -- recursive tycon/class -getTyBinding2 rec_env (name, (tc_kind, maybe_arity, thing)) +getTyBinding2 rec_env (name, (tc_kind, thing)) = zonkTcKindToKind tc_kind `thenNF_Tc` \ kind -> - returnNF_Tc (name, (kind, maybe_arity, mk_thing thing (lookupUFM rec_env name))) + returnNF_Tc (name, (kind, mk_thing thing (lookupUFM rec_env name))) where - mk_thing (ATyCon _) ~(Just (ATyCon tc)) = ATyCon tc - mk_thing (AClass _) ~(Just (AClass cls)) = AClass cls + mk_thing (ADataTyCon _) ~(Just (ADataTyCon tc)) = ADataTyCon tc + mk_thing (ASynTyCon _ arity) ~(Just (ASynTyCon tc _)) = ASynTyCon tc arity + mk_thing (AClass _ arity) ~(Just (AClass cls _)) = AClass cls arity \end{code} @@ -272,7 +266,7 @@ mk_cls_edges other_decl ---------------------------------------------------- mk_edges :: RenamedTyClDecl -> (RenamedTyClDecl, Unique, [Unique]) -mk_edges decl@(TyData _ ctxt name _ condecls derivs _ _) +mk_edges decl@(TyData _ ctxt name _ condecls _ derivs _ _) = (decl, getUnique name, uniqSetToList (get_ctxt ctxt `unionUniqSets` get_cons condecls `unionUniqSets` get_deriv derivs)) @@ -313,30 +307,20 @@ get_bty (Unbanged ty) = get_ty ty get_bty (Unpacked ty) = get_ty ty ---------------------------------------------------- -get_ty (MonoTyVar name) - = if isTvOcc (nameOccName name) then emptyUniqSet else set_name name -get_ty (MonoTyApp ty1 ty2) - = unionUniqSets (get_ty ty1) (get_ty ty2) -get_ty (MonoFunTy ty1 ty2) - = unionUniqSets (get_ty ty1) (get_ty ty2) -get_ty (MonoListTy ty) - = set_name listTyCon_name `unionUniqSets` get_ty ty -get_ty (MonoTupleTy tys boxed) - = set_name (tupleTyCon_name boxed (length tys)) `unionUniqSets` get_tys tys -get_ty (MonoUsgTy _ ty) - = get_ty ty -get_ty (MonoUsgForAllTy _ ty) - = get_ty ty -get_ty (HsForAllTy _ ctxt mty) - = get_ctxt ctxt `unionUniqSets` get_ty mty -get_ty (MonoDictTy name _) - = set_name name -get_ty (MonoIParamTy name _) - = emptyUniqSet +get_ty (HsTyVar name) | isTvOcc (nameOccName name) = emptyUniqSet + | otherwise = set_name name +get_ty (HsAppTy ty1 ty2) = unionUniqSets (get_ty ty1) (get_ty ty2) +get_ty (HsFunTy ty1 ty2) = unionUniqSets (get_ty ty1) (get_ty ty2) +get_ty (HsListTy ty) = set_name listTyCon_name `unionUniqSets` get_ty ty +get_ty (HsTupleTy (HsTupCon n _) tys) = set_name n `unionUniqSets` get_tys tys +get_ty (HsUsgTy _ ty) = get_ty ty +get_ty (HsUsgForAllTy _ ty) = get_ty ty +get_ty (HsForAllTy _ ctxt mty) = get_ctxt ctxt `unionUniqSets` get_ty mty +get_ty (HsPredTy (HsPClass name _)) = set_name name +get_ty (HsPredTy (HsPIParam _ _)) = emptyUniqSet -- I think ---------------------------------------------------- -get_tys tys - = unionManyUniqSets (map get_ty tys) +get_tys tys = unionManyUniqSets (map get_ty tys) ---------------------------------------------------- get_sigs sigs diff --git a/ghc/compiler/typecheck/TcTyDecls.lhs b/ghc/compiler/typecheck/TcTyDecls.lhs index 450dad952c..a6f151d3b8 100644 --- a/ghc/compiler/typecheck/TcTyDecls.lhs +++ b/ghc/compiler/typecheck/TcTyDecls.lhs @@ -25,7 +25,7 @@ import TcMonoType ( tcExtendTopTyVarScope, tcExtendTyVarScope, tcContext, tcHsTopTypeKind ) import TcType ( zonkTcTyVarToTyVar, zonkTcClassConstraints ) -import TcEnv ( tcLookupTy, TcTyThing(..) ) +import TcEnv ( tcLookupTy, tcLookupValueByKey, TcTyThing(..) ) import TcMonad import TcUnify ( unifyKind ) @@ -40,7 +40,7 @@ import Var ( Id, TyVar ) import Name ( Name, isLocallyDefined, OccName, NamedThing(..), nameUnique ) import Outputable import TyCon ( TyCon, AlgTyConFlavour(..), ArgVrcs, mkSynTyCon, mkAlgTyCon, - tyConDataCons, tyConTyVars, + tyConDataConsIfAvailable, tyConTyVars, isSynTyCon, isNewTyCon ) import Type ( getTyVar, tyVarsOfTypes, splitFunTy, applyTys, @@ -52,6 +52,7 @@ import Type ( getTyVar, tyVarsOfTypes, splitFunTy, applyTys, import TysWiredIn ( unitTy ) import Var ( tyVarKind ) import VarSet ( intersectVarSet, isEmptyVarSet ) +import Unique ( unpackCStringIdKey ) import Util ( equivClasses ) import FiniteMap ( FiniteMap, lookupWithDefaultFM ) import CmdLineOpts ( opt_GlasgowExts ) @@ -67,13 +68,13 @@ import CmdLineOpts ( opt_GlasgowExts ) kcTyDecl :: RenamedTyClDecl -> TcM s () kcTyDecl (TySynonym name tyvar_names rhs src_loc) - = tcLookupTy name `thenNF_Tc` \ (kind, _, _) -> + = tcLookupTy name `thenNF_Tc` \ (kind, _) -> tcExtendTopTyVarScope kind tyvar_names $ \ _ result_kind -> tcHsTypeKind rhs `thenTc` \ (rhs_kind, _) -> unifyKind result_kind rhs_kind -kcTyDecl (TyData _ context tycon_name tyvar_names con_decls _ _ src_loc) - = tcLookupTy tycon_name `thenNF_Tc` \ (kind, _, _) -> +kcTyDecl (TyData _ context tycon_name tyvar_names con_decls _ _ _ src_loc) + = tcLookupTy tycon_name `thenNF_Tc` \ (kind, _) -> tcExtendTopTyVarScope kind tyvar_names $ \ result_kind _ -> tcContext context `thenTc_` mapTc kcConDecl con_decls `thenTc_` @@ -107,10 +108,10 @@ kcConDecl (ConDecl _ _ ex_tvs ex_ctxt details loc) %************************************************************************ \begin{code} -tcTyDecl :: RecFlag -> FiniteMap Name ArgVrcs -> RenamedTyClDecl -> TcM s TyCon +tcTyDecl :: RecFlag -> FiniteMap Name ArgVrcs -> RenamedTyClDecl -> TcM s (Name, TcTyThing) tcTyDecl is_rec rec_vrcs (TySynonym tycon_name tyvar_names rhs src_loc) - = tcLookupTy tycon_name `thenNF_Tc` \ (tycon_kind, Just arity, _) -> + = tcLookupTy tycon_name `thenNF_Tc` \ (tycon_kind, ASynTyCon _ arity) -> tcExtendTopTyVarScope tycon_kind tyvar_names $ \ tyvars _ -> tcHsTopTypeKind rhs `thenTc` \ (_, rhs_ty) -> -- If the RHS mentions tyvars that aren't in scope, we'll @@ -123,12 +124,12 @@ tcTyDecl is_rec rec_vrcs (TySynonym tycon_name tyvar_names rhs src_loc) tycon_name tycon = mkSynTyCon tycon_name tycon_kind arity tyvars rhs_ty argvrcs in - returnTc tycon + returnTc (tycon_name, ASynTyCon tycon arity) -tcTyDecl is_rec rec_vrcs (TyData data_or_new context tycon_name tyvar_names con_decls derivings pragmas src_loc) +tcTyDecl is_rec rec_vrcs (TyData data_or_new context tycon_name tyvar_names con_decls nconstrs derivings pragmas src_loc) = -- Lookup the pieces - tcLookupTy tycon_name `thenNF_Tc` \ (tycon_kind, _, ATyCon rec_tycon) -> + tcLookupTy tycon_name `thenNF_Tc` \ (tycon_kind, ADataTyCon rec_tycon) -> tcExtendTopTyVarScope tycon_kind tyvar_names $ \ tyvars _ -> -- Typecheck the pieces @@ -148,16 +149,16 @@ tcTyDecl is_rec rec_vrcs (TyData data_or_new context tycon_name tyvar_names con_ tycon_name tycon = mkAlgTyCon tycon_name tycon_kind tyvars ctxt' argvrcs - data_cons + data_cons nconstrs derived_classes flavour is_rec in - returnTc tycon + returnTc (tycon_name, ADataTyCon tycon) where tc_derivs Nothing = returnTc [] tc_derivs (Just ds) = mapTc tc_deriv ds - tc_deriv name = tcLookupTy name `thenTc` \ (_, _, AClass clas) -> + tc_deriv name = tcLookupTy name `thenTc` \ (_, AClass clas _) -> returnTc clas \end{code} @@ -313,7 +314,9 @@ mkImplicitDataBinds_one tycon in returnTc (all_ids, binds) where - data_cons = tyConDataCons tycon + data_cons = tyConDataConsIfAvailable tycon + -- Abstract types mean we don't bring the + -- data cons into scope, which should be fine data_con_wrapper_ids = map dataConWrapId data_cons @@ -336,7 +339,8 @@ mkRecordSelector tycon fields@((first_con, first_field_label) : other_fields) -- data type use the same type variables = checkTc (all (== field_ty) other_tys) (fieldTypeMisMatch field_name) `thenTc_` - returnTc (mkRecordSelId tycon first_field_label) + tcLookupValueByKey unpackCStringIdKey `thenTc` \ unpack_id -> + returnTc (mkRecordSelId tycon first_field_label unpack_id) where field_ty = fieldLabelType first_field_label field_name = fieldLabelName first_field_label diff --git a/ghc/compiler/typecheck/TcUnify.lhs b/ghc/compiler/typecheck/TcUnify.lhs index 09695e77fe..9d684c1999 100644 --- a/ghc/compiler/typecheck/TcUnify.lhs +++ b/ghc/compiler/typecheck/TcUnify.lhs @@ -8,7 +8,7 @@ updatable substitution). \begin{code} module TcUnify ( unifyTauTy, unifyTauTyList, unifyTauTyLists, - unifyFunTy, unifyListTy, unifyTupleTy, unifyUnboxedTupleTy, + unifyFunTy, unifyListTy, unifyTupleTy, unifyKind, unifyKinds, unifyTypeKind ) where @@ -25,8 +25,7 @@ import Type ( tyVarsOfType, splitAppTy_maybe, tidyOpenType, tidyOpenTypes, tidyTyVar ) -import TyCon ( TyCon, isTupleTyCon, isUnboxedTupleTyCon, - tyConArity ) +import TyCon ( TyCon, isTupleTyCon, tupleTyConBoxity, tyConArity ) import Name ( hasBetterProv ) import Var ( TyVar, tyVarKind, varName, isSigTyVar ) import VarEnv @@ -36,8 +35,8 @@ import TcType ( TcType, TcTauType, TcTyVar, TcKind, tcGetTyVar, tcPutTyVar, zonkTcType, tcTypeKind ) -- others: -import BasicTypes ( Arity ) -import TysWiredIn ( listTyCon, mkListTy, mkTupleTy, mkUnboxedTupleTy ) +import BasicTypes ( Arity, Boxity, isBoxed ) +import TysWiredIn ( listTyCon, mkListTy, mkTupleTy ) import PprType () -- Instances import Util import Outputable @@ -404,45 +403,29 @@ unify_list_ty_help ty -- Revert to ordinary unification \end{code} \begin{code} -unifyTupleTy :: Arity -> TcType -> TcM s [TcType] -unifyTupleTy arity ty@(TyVarTy tyvar) +unifyTupleTy :: Boxity -> Arity -> TcType -> TcM s [TcType] +unifyTupleTy boxity arity ty@(TyVarTy tyvar) = tcGetTyVar tyvar `thenNF_Tc` \ maybe_ty -> case maybe_ty of - Just ty' -> unifyTupleTy arity ty' - other -> unify_tuple_ty_help arity ty + Just ty' -> unifyTupleTy boxity arity ty' + other -> unify_tuple_ty_help boxity arity ty -unifyTupleTy arity ty +unifyTupleTy boxity arity ty = case splitTyConApp_maybe ty of - Just (tycon, arg_tys) | isTupleTyCon tycon - && tyConArity tycon == arity - -> returnTc arg_tys - other -> unify_tuple_ty_help arity ty - -unify_tuple_ty_help arity ty - = mapNF_Tc (\ _ -> newTyVarTy boxedTypeKind) [1..arity] `thenNF_Tc` \ arg_tys -> - unifyTauTy ty (mkTupleTy arity arg_tys) `thenTc_` - returnTc arg_tys -\end{code} - -\begin{code} -unifyUnboxedTupleTy :: Arity -> TcType -> TcM s [TcType] -unifyUnboxedTupleTy arity ty@(TyVarTy tyvar) - = tcGetTyVar tyvar `thenNF_Tc` \ maybe_ty -> - case maybe_ty of - Just ty' -> unifyUnboxedTupleTy arity ty' - other -> unify_unboxed_tuple_ty_help arity ty - -unifyUnboxedTupleTy arity ty - = case splitTyConApp_maybe ty of - Just (tycon, arg_tys) | isUnboxedTupleTyCon tycon - && tyConArity tycon == arity - -> returnTc arg_tys - other -> unify_tuple_ty_help arity ty - -unify_unboxed_tuple_ty_help arity ty - = mapNF_Tc (\ _ -> newTyVarTy_OpenKind) [1..arity] `thenNF_Tc` \ arg_tys -> - unifyTauTy ty (mkUnboxedTupleTy arity arg_tys) `thenTc_` + Just (tycon, arg_tys) + | isTupleTyCon tycon + && tyConArity tycon == arity + && tupleTyConBoxity tycon == boxity + -> returnTc arg_tys + other -> unify_tuple_ty_help boxity arity ty + +unify_tuple_ty_help boxity arity ty + = mapNF_Tc new_tyvar [1..arity] `thenNF_Tc` \ arg_tys -> + unifyTauTy ty (mkTupleTy boxity arity arg_tys) `thenTc_` returnTc arg_tys + where + new_tyvar _ | isBoxed boxity = newTyVarTy boxedTypeKind + | otherwise = newTyVarTy_OpenKind \end{code} Make sure a kind is of the form (Type b) for some boxity b. diff --git a/ghc/compiler/types/Class.lhs b/ghc/compiler/types/Class.lhs index 035a12c2af..781e342628 100644 --- a/ghc/compiler/types/Class.lhs +++ b/ghc/compiler/types/Class.lhs @@ -5,7 +5,7 @@ \begin{code} module Class ( - Class, ClassOpItem, + Class, ClassOpItem, ClassPred, ClassContext, FunDep, mkClass, classTyVars, classKey, className, classSelIds, classTyCon, @@ -40,7 +40,7 @@ data Class className :: Name, classTyVars :: [TyVar], -- The class type variables - classFunDeps :: [([TyVar], [TyVar])], -- The functional dependencies + classFunDeps :: [FunDep TyVar], -- The functional dependencies classSCTheta :: [(Class,[Type])], -- Immediate superclasses, and the classSCSels :: [Id], -- corresponding selector functions to @@ -54,6 +54,12 @@ data Class classTyCon :: TyCon -- The data type constructor for dictionaries } -- of this class +type ClassPred = (Class, [Type]) +type ClassContext = [ClassPred] + +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, -- Selector function; contains unfolding Id, -- Default methods Bool) -- True <=> an explicit default method was diff --git a/ghc/compiler/types/FunDeps.lhs b/ghc/compiler/types/FunDeps.lhs index c1db64ebab..686d98d6c4 100644 --- a/ghc/compiler/types/FunDeps.lhs +++ b/ghc/compiler/types/FunDeps.lhs @@ -15,20 +15,34 @@ module FunDeps ( #include "HsVersions.h" -import Class ( classTvsFds ) -import Type ( tyVarsOfType ) -import Outputable ( interppSP, ptext, empty, hsep, punctuate, comma ) -import UniqSet ( elementOfUniqSet, addOneToUniqSet, - uniqSetToList, unionManyUniqSets ) +import Var ( TyVar ) +import Class ( Class, FunDep, classTvsFds ) +import Type ( Type, tyVarsOfTypes ) +import Outputable ( Outputable, SDoc, interppSP, ptext, empty, hsep, punctuate, comma ) +import UniqSet +import VarSet +import Unique ( Uniquable ) import List ( elemIndex ) \end{code} \begin{code} +oclose :: Uniquable a => [FunDep a] -> UniqSet a -> UniqSet a +-- (oclose fds tvs) closes the set of type variables tvs, +-- wrt the functional dependencies fds. The result is a superset +-- of the argument set. +-- +-- For example, +-- oclose [a -> b] {a} = {a,b} +-- oclose [a b -> c] {a} = {a} +-- oclose [a b -> c] {a,b} = {a,b,c} +-- If all of the things on the left of an arrow are in the set, add +-- the things on the right of that arrow. + oclose fds vs = case oclose1 fds vs of (vs', False) -> vs' - (vs', True) -> oclose fds vs' + (vs', True) -> oclose fds vs' oclose1 [] vs = (vs, False) oclose1 (fd@(ls, rs):fds) vs = @@ -44,30 +58,32 @@ osubset [] vs = True osubset (u:us) vs = if u `elementOfUniqSet` vs then osubset us vs else False ounion [] ys = (ys, False) -ounion (x:xs) ys = - if x `elementOfUniqSet` ys then (ys', b) else (addOneToUniqSet ys' x, True) +ounion (x:xs) ys + | x `elementOfUniqSet` ys = (ys', b) + | otherwise = (addOneToUniqSet ys' x, True) where (ys', b) = ounion xs ys -instantiateFdClassTys clas ts = - map (lookupInstFundep tyvars ts) fundeps - where - (tyvars, fundeps) = classTvsFds clas - lookupInstFundep tyvars ts (us, vs) = - (lookupInstTys tyvars ts us, lookupInstTys tyvars ts vs) +instantiateFdClassTys :: Class -> [a] -> [([a], [a])] +-- Get the FDs of the class, and instantiate them +instantiateFdClassTys clas ts + = map (lookupInstFundep tyvars ts) fundeps + where + (tyvars, fundeps) = classTvsFds clas + lookupInstFundep tyvars ts (us, vs) + = (lookupInstTys tyvars ts us, lookupInstTys tyvars ts vs) + lookupInstTys tyvars ts = map (lookupInstTy tyvars ts) lookupInstTy tyvars ts u = ts !! i where Just i = elemIndex u tyvars -tyVarFunDep fdtys = - map (\(xs, ys) -> (unionMap getTyVars xs, unionMap getTyVars ys)) fdtys - where - getTyVars ty = tyVarsOfType ty - unionMap f xs = uniqSetToList (unionManyUniqSets (map f xs)) +tyVarFunDep :: [FunDep Type] -> [FunDep TyVar] +tyVarFunDep fdtys + = [(varSetElems (tyVarsOfTypes xs), varSetElems (tyVarsOfTypes xs)) | (xs,ys) <- fdtys] +pprFundeps :: Outputable a => [FunDep a] -> SDoc pprFundeps [] = empty pprFundeps fds = hsep (ptext SLIT("|") : punctuate comma (map ppr_fd fds)) ppr_fd (us, vs) = hsep [interppSP us, ptext SLIT("->"), interppSP vs] - \end{code} diff --git a/ghc/compiler/types/PprType.lhs b/ghc/compiler/types/PprType.lhs index 8d0d675569..6b22faa886 100644 --- a/ghc/compiler/types/PprType.lhs +++ b/ghc/compiler/types/PprType.lhs @@ -116,7 +116,7 @@ ppr_ty env ctxt_prec (TyVarTy tyvar) ppr_ty env ctxt_prec ty@(TyConApp tycon tys) -- KIND CASE; it's of the form (Type x) - | tycon_uniq == typeConKey && n_tys == 1 + | tycon `hasKey` typeConKey && n_tys == 1 = -- For kinds, print (Type x) as just x if x is a -- type constructor (must be Boxed, Unboxed, AnyBox) -- Otherwise print as (Type x) @@ -136,7 +136,7 @@ ppr_ty env ctxt_prec ty@(TyConApp tycon tys) = parens (char '#' <+> tys_w_commas <+> char '#') -- LIST CASE - | tycon_uniq == listTyConKey && n_tys == 1 + | tycon `hasKey` listTyConKey && n_tys == 1 = brackets (ppr_ty env tOP_PREC ty1) -- DICTIONARY CASE, prints {C a} @@ -154,7 +154,6 @@ ppr_ty env ctxt_prec ty@(TyConApp tycon tys) = maybeParen ctxt_prec tYCON_PREC (sep [ppr tycon, nest 4 tys_w_spaces]) where - tycon_uniq = tyConUnique tycon n_tys = length tys (ty1:_) = tys Just pred = maybe_pred @@ -167,18 +166,11 @@ ppr_ty env ctxt_prec ty@(TyConApp tycon tys) ppr_ty env ctxt_prec ty@(ForAllTy _ _) = getPprStyle $ \ sty -> maybeParen ctxt_prec fUN_PREC $ - if ifaceStyle sty then - sep [ ptext SLIT("__forall") <+> brackets pp_tyvars <+> ptext SLIT("=>"), - ppr_ty env tOP_PREC rho - ] - else - -- The type checker occasionally prints a type in an error message, - -- and it had better come out looking like a user type - sep [ ptext SLIT("forall") <+> pp_tyvars <> ptext SLIT("."), - ppr_theta theta, - ppr_ty env tOP_PREC tau - ] - where + sep [ ptext SLIT("forall") <+> pp_tyvars <> ptext SLIT("."), + ppr_theta theta, + ppr_ty env tOP_PREC tau + ] + where (tyvars, rho) = splitForAllTys ty -- don't treat theta specially any more (KSW 1999-04) (theta, tau) = splitRhoTy rho @@ -267,7 +259,7 @@ and when in debug mode. \begin{code} pprTyVarBndr tyvar = getPprStyle $ \ sty -> - if (ifaceStyle sty || debugStyle sty) && kind /= boxedTypeKind then + if (ifaceStyle sty && kind /= boxedTypeKind) || debugStyle sty then hsep [ppr tyvar, dcolon, pprParendKind kind] -- See comments with ppDcolon in PprCore.lhs else diff --git a/ghc/compiler/types/TyCon.lhs b/ghc/compiler/types/TyCon.lhs index 1ca3393d4d..48445e4e9c 100644 --- a/ghc/compiler/types/TyCon.lhs +++ b/ghc/compiler/types/TyCon.lhs @@ -9,7 +9,8 @@ module TyCon( isFunTyCon, isUnLiftedTyCon, isBoxedTyCon, isProductTyCon, isAlgTyCon, isDataTyCon, isSynTyCon, isNewTyCon, isPrimTyCon, - isEnumerationTyCon, isTupleTyCon, isUnboxedTupleTyCon, + isEnumerationTyCon, + isTupleTyCon, isUnboxedTupleTyCon, isBoxedTupleTyCon, tupleTyConBoxity, isRecursiveTyCon, newTyConRep, mkAlgTyCon, @@ -27,7 +28,7 @@ module TyCon( tyConUnique, tyConTyVars, tyConArgVrcs_maybe, - tyConDataCons, + tyConDataCons, tyConDataConsIfAvailable, tyConFamilySize, tyConDerivings, tyConTheta, @@ -49,9 +50,9 @@ import {-# SOURCE #-} TypeRep ( Type, Kind, SuperKind ) import {-# SOURCE #-} DataCon ( DataCon, isExistentialDataCon ) -import Class ( Class ) +import Class ( Class, ClassContext ) import Var ( TyVar ) -import BasicTypes ( Arity, NewOrData(..), RecFlag(..) ) +import BasicTypes ( Arity, NewOrData(..), RecFlag(..), Boxity(..), isBoxed ) import Maybes import Name ( Name, nameUnique, NamedThing(getName) ) import Unique ( Unique, Uniquable(..), anyBoxConKey ) @@ -87,7 +88,7 @@ data TyCon tyConTyVars :: [TyVar], tyConArgVrcs :: ArgVrcs, - algTyConTheta :: [(Class,[Type])], + algTyConTheta :: ClassContext, dataCons :: [DataCon], -- Its data constructors, with fully polymorphic types @@ -97,6 +98,13 @@ data TyCon -- (b) in a quest for fast compilation we don't import -- the constructors + noOfDataCons :: Int, -- Number of data constructors + -- Usually this is the same as the length of the + -- dataCons field, but the latter may be empty if + -- we imported the type abstractly. But even if we import + -- abstractly we still need to know the number of constructors + -- so we can get the return convention right. Tiresome! + algTyConDerivings :: [Class], -- Classes which have derived instances algTyConFlavour :: AlgTyConFlavour, @@ -125,7 +133,7 @@ data TyCon tyConName :: Name, tyConKind :: Kind, tyConArity :: Arity, - tyConBoxed :: Bool, -- True for boxed; False for unboxed + tyConBoxed :: Boxity, tyConTyVars :: [TyVar], dataCon :: DataCon } @@ -213,7 +221,7 @@ mkFunTyCon name kind tyConArity = 2 } -mkAlgTyCon name kind tyvars theta argvrcs cons derivs flavour rec +mkAlgTyCon name kind tyvars theta argvrcs cons ncons derivs flavour rec = AlgTyCon { tyConName = name, tyConUnique = nameUnique name, @@ -223,6 +231,7 @@ mkAlgTyCon name kind tyvars theta argvrcs cons derivs flavour rec tyConArgVrcs = argvrcs, algTyConTheta = theta, dataCons = cons, + noOfDataCons = ncons, algTyConDerivings = derivs, algTyConClass_maybe = Nothing, algTyConFlavour = flavour, @@ -239,6 +248,7 @@ mkClassTyCon name kind tyvars argvrcs con clas flavour tyConArgVrcs = argvrcs, algTyConTheta = [], dataCons = [con], + noOfDataCons = 1, algTyConDerivings = [], algTyConClass_maybe = Just clas, algTyConFlavour = flavour, @@ -289,13 +299,13 @@ isPrimTyCon (PrimTyCon {}) = True isPrimTyCon _ = False isUnLiftedTyCon (PrimTyCon {}) = True -isUnLiftedTyCon (TupleTyCon { tyConBoxed = False }) = True +isUnLiftedTyCon (TupleTyCon { tyConBoxed = boxity}) = not (isBoxed boxity) isUnLiftedTyCon _ = False -- isBoxedTyCon should not be applied to SynTyCon, nor KindCon isBoxedTyCon (AlgTyCon {}) = True isBoxedTyCon (FunTyCon {}) = True -isBoxedTyCon (TupleTyCon {tyConBoxed = boxed}) = boxed +isBoxedTyCon (TupleTyCon {tyConBoxed = boxity}) = isBoxed boxity isBoxedTyCon (PrimTyCon {primTyConRep = rep}) = isFollowableRep rep -- isAlgTyCon returns True for both @data@ and @newtype@ @@ -307,7 +317,7 @@ isAlgTyCon other = False isDataTyCon (AlgTyCon {algTyConFlavour = new_or_data}) = case new_or_data of NewTyCon _ -> False other -> True -isDataTyCon (TupleTyCon {tyConBoxed = True}) = True +isDataTyCon (TupleTyCon {tyConBoxed = boxity}) = isBoxed boxity isDataTyCon other = False isNewTyCon (AlgTyCon {algTyConFlavour = NewTyCon _}) = True @@ -333,29 +343,40 @@ isSynTyCon _ = False isEnumerationTyCon (AlgTyCon {algTyConFlavour = EnumTyCon}) = True isEnumerationTyCon other = False --- The unit tycon isn't classed as a tuple tycon -isTupleTyCon (TupleTyCon {tyConArity = arity, tyConBoxed = True}) = arity >= 2 -isTupleTyCon other = False +-- The unit tycon didn't used to be classed as a tuple tycon +-- but I thought that was silly so I've undone it +-- If it can't be for some reason, it should be a AlgTyCon +isTupleTyCon (TupleTyCon {}) = True +isTupleTyCon other = False -isUnboxedTupleTyCon (TupleTyCon {tyConBoxed = False}) = True +isUnboxedTupleTyCon (TupleTyCon {tyConBoxed = boxity}) = not (isBoxed boxity) isUnboxedTupleTyCon other = False +isBoxedTupleTyCon (TupleTyCon {tyConBoxed = boxity}) = isBoxed boxity +isBoxedTupleTyCon other = False + +tupleTyConBoxity tc = tyConBoxed tc + isRecursiveTyCon (AlgTyCon {algTyConRec = Recursive}) = True isRecursiveTyCon other = False \end{code} \begin{code} tyConDataCons :: TyCon -> [DataCon] -tyConDataCons (AlgTyCon {dataCons = cons}) = cons -tyConDataCons (TupleTyCon {dataCon = con}) = [con] -tyConDataCons other = [] +tyConDataCons tycon = ASSERT2( not (null cons), ppr tycon ) cons + where + cons = tyConDataConsIfAvailable tycon + +tyConDataConsIfAvailable (AlgTyCon {dataCons = cons}) = cons -- Empty for abstract types +tyConDataConsIfAvailable (TupleTyCon {dataCon = con}) = [con] +tyConDataConsIfAvailable other = [] -- You may think this last equation should fail, -- but it's quite convenient to return no constructors for -- a synonym; see for example the call in TcTyClsDecls. tyConFamilySize :: TyCon -> Int -tyConFamilySize (AlgTyCon {dataCons = cons}) = length cons -tyConFamilySize (TupleTyCon {}) = 1 +tyConFamilySize (AlgTyCon {noOfDataCons = n}) = n +tyConFamilySize (TupleTyCon {}) = 1 #ifdef DEBUG tyConFamilySize other = pprPanic "tyConFamilySize:" (ppr other) #endif @@ -372,7 +393,7 @@ tyConDerivings other = [] \end{code} \begin{code} -tyConTheta :: TyCon -> [(Class, [Type])] +tyConTheta :: TyCon -> ClassContext tyConTheta (AlgTyCon {algTyConTheta = theta}) = theta -- should ask about anything else \end{code} diff --git a/ghc/compiler/types/Type.lhs b/ghc/compiler/types/Type.lhs index b54183e97c..877b115203 100644 --- a/ghc/compiler/types/Type.lhs +++ b/ghc/compiler/types/Type.lhs @@ -93,7 +93,7 @@ import VarSet import Name ( Name, NamedThing(..), mkLocalName, tidyOccName ) import NameSet -import Class ( classTyCon, Class ) +import Class ( classTyCon, Class, ClassPred, ClassContext ) import TyCon ( TyCon, isUnboxedTupleTyCon, isUnLiftedTyCon, isFunTyCon, isDataTyCon, isNewTyCon, newTyConRep, @@ -316,7 +316,7 @@ splitTyConApp_maybe other = Nothing -- splitAlgTyConApp_maybe looks for -- *saturated* applications of *algebraic* data types -- "Algebraic" => newtype, data type, or dictionary (not function types) --- We return the constructors too. +-- We return the constructors too, so there had better be some. splitAlgTyConApp_maybe :: Type -> Maybe (TyCon, [Type], [DataCon]) splitAlgTyConApp_maybe (TyConApp tc tys) @@ -332,6 +332,9 @@ splitAlgTyConApp :: Type -> (TyCon, [Type], [DataCon]) splitAlgTyConApp (TyConApp tc tys) = ASSERT( isAlgTyCon tc && tyConArity tc == length tys ) (tc, tys, tyConDataCons tc) splitAlgTyConApp (NoteTy _ ty) = splitAlgTyConApp ty +#ifdef DEBUG +splitAlgTyConApp ty = pprPanic "splitAlgTyConApp" (pprType ty) +#endif \end{code} "Dictionary" types are just ordinary data types, but you can @@ -687,14 +690,14 @@ ClassPred and ClassContext are used in class and instance declarations. %************************************************************************ \begin{code} -type RhoType = Type -type TauType = Type data PredType = Class Class [Type] | IParam Name Type -type ThetaType = [PredType] -type ClassPred = (Class, [Type]) -type ClassContext = [ClassPred] -type SigmaType = Type + deriving( Eq, Ord ) + +type ThetaType = [PredType] +type RhoType = Type +type TauType = Type +type SigmaType = Type \end{code} \begin{code} diff --git a/ghc/compiler/types/TypeRep.lhs b/ghc/compiler/types/TypeRep.lhs index b5e04a1299..b71576bf06 100644 --- a/ghc/compiler/types/TypeRep.lhs +++ b/ghc/compiler/types/TypeRep.lhs @@ -38,7 +38,7 @@ import TyCon ( TyCon, KindCon, -- others import SrcLoc ( mkBuiltinSrcLoc ) -import PrelMods ( pREL_GHC ) +import PrelNames ( pREL_GHC ) import Unique -- quite a few *Keys import Util ( thenCmp ) \end{code} diff --git a/ghc/compiler/types/Variance.lhs b/ghc/compiler/types/Variance.lhs index dfab7a80f1..b3fe0a5f1a 100644 --- a/ghc/compiler/types/Variance.lhs +++ b/ghc/compiler/types/Variance.lhs @@ -12,7 +12,7 @@ module Variance( #include "HsVersions.h" import TypeRep ( Type(..), TyNote(..) ) -- friend -import TyCon ( TyCon, ArgVrcs, tyConKind, tyConArity, tyConDataCons, tyConTyVars, +import TyCon ( TyCon, ArgVrcs, tyConKind, tyConArity, tyConDataConsIfAvailable, tyConTyVars, tyConArgVrcs_maybe, getSynTyConDefn, isSynTyCon, isAlgTyCon ) import DataCon ( dataConRepArgTys ) @@ -45,7 +45,7 @@ calcTyConArgVrcs :: [TyCon] calcTyConArgVrcs tycons = let oi = foldl (\fm tc -> addToFM fm tc (initial tc)) emptyFM tycons - initial tc = if isAlgTyCon tc && null (tyConDataCons tc) then + initial tc = if isAlgTyCon tc && null (tyConDataConsIfAvailable tc) then -- make pessimistic assumption (and warn) take (tyConArity tc) abstractVrcs else @@ -75,15 +75,20 @@ calcTyConArgVrcs tycons -> ArgVrcs -- new ArgVrcs for tycon tcaoIter oi tc | isAlgTyCon tc - = let cs = tyConDataCons tc - vs = tyConTyVars tc - argtys = concatMap dataConRepArgTys cs - myfao tc = lookupWithDefaultFM oi (expectJust "tcaoIter(Alg)" $ - tyConArgVrcs_maybe tc) - tc - -- we use the already-computed result for tycons not in this SCC - in map (\v -> anyVrc (\ty -> vrcInTy myfao v ty) argtys) + = if null data_cons then + -- Abstract types get uninformative variances + abstractVrcs + else + map (\v -> anyVrc (\ty -> vrcInTy myfao v ty) argtys) vs + where + data_cons = tyConDataConsIfAvailable 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 diff --git a/ghc/compiler/usageSP/UsageSPInf.lhs b/ghc/compiler/usageSP/UsageSPInf.lhs index d0f062e003..b0f5f56b52 100644 --- a/ghc/compiler/usageSP/UsageSPInf.lhs +++ b/ghc/compiler/usageSP/UsageSPInf.lhs @@ -18,6 +18,7 @@ import UsageSPLint import UConSet import CoreSyn +import CoreFVs ( mustHaveLocalBinding ) import Rules ( RuleBase ) import TypeRep ( Type(..), TyNote(..) ) -- friend import Type ( UsageAnn(..), @@ -31,7 +32,7 @@ import TyCon ( tyConArgVrcs_maybe, isFunTyCon ) import Literal ( Literal(..), literalType ) import Var ( Var, UVar, varType, setVarType, mkUVar, modifyIdInfo ) import IdInfo ( setLBVarInfo, LBVarInfo(..) ) -import Id ( mayHaveNoBinding, isExportedId ) +import Id ( isExportedId ) import Name ( isLocallyDefined ) import VarEnv import VarSet @@ -398,7 +399,7 @@ lookupVar :: VarEnv Var -> Var -> Var --lookupVar ve v = error "lookupVar unimplemented" lookupVar ve v = case lookupVarEnv ve v of Just v' -> v' - Nothing -> ASSERT( not (isLocallyDefined v) || (mayHaveNoBinding v) ) + Nothing -> ASSERT( not (mustHaveLocalBinding v) ) ASSERT( isUsgTy (varType v) ) v diff --git a/ghc/compiler/usageSP/UsageSPUtils.lhs b/ghc/compiler/usageSP/UsageSPUtils.lhs index 1628413e31..4fb51f0eeb 100644 --- a/ghc/compiler/usageSP/UsageSPUtils.lhs +++ b/ghc/compiler/usageSP/UsageSPUtils.lhs @@ -25,9 +25,10 @@ module UsageSPUtils ( AnnotM(AnnotM), initAnnotM, #include "HsVersions.h" import CoreSyn +import CoreFVs ( mustHaveLocalBinding ) import Literal ( Literal(..) ) import Var ( Var, varName, varType, setVarType, mkUVar ) -import Id ( mayHaveNoBinding, isExportedId ) +import Id ( isExportedId ) import Name ( isLocallyDefined ) import TypeRep ( Type(..), TyNote(..) ) -- friend import Type ( UsageAnn(..), isUsgTy, splitFunTys ) @@ -182,8 +183,7 @@ assumed true (exactly) of all imported ids. \begin{code} hasLocalDef :: Var -> Bool -hasLocalDef var = isLocallyDefined var - && not (mayHaveNoBinding var) +hasLocalDef var = mustHaveLocalBinding var hasUsgInfo :: Var -> Bool hasUsgInfo var = (not . isLocallyDefined) var diff --git a/ghc/compiler/utils/Digraph.lhs b/ghc/compiler/utils/Digraph.lhs index 7ac34b2637..0dfc585c2d 100644 --- a/ghc/compiler/utils/Digraph.lhs +++ b/ghc/compiler/utils/Digraph.lhs @@ -153,7 +153,7 @@ graphFromEdges edges edges1 = zipWith (,) [0..] sorted_edges graph = array bounds [(,) v (mapMaybe key_vertex ks) | (,) v (_, _, ks) <- edges1] - key_map = array bounds [(,) v k | (,) v (_, k, _ ) <- edges1] + key_map = array bounds [(,) v k | (,) v (_, k, _ ) <- edges1] vertex_map = array bounds edges1 (_,k1,_) `lt` (_,k2,_) = case k1 `compare` k2 of { LT -> True; other -> False } diff --git a/ghc/compiler/utils/Outputable.lhs b/ghc/compiler/utils/Outputable.lhs index 19ad666677..46cb73462c 100644 --- a/ghc/compiler/utils/Outputable.lhs +++ b/ghc/compiler/utils/Outputable.lhs @@ -179,7 +179,7 @@ printForAsm handle doc = printDoc LeftMode handle (doc (PprCode AsmStyle)) -- printForIface prints all on one line for interface files. -- It's called repeatedly for successive lines printForIface :: Handle -> SDoc -> IO () -printForIface handle doc = printDoc OneLineMode handle (doc PprInterface) +printForIface handle doc = printDoc LeftMode handle (doc PprInterface) pprCode :: CodeStyle -> SDoc -> SDoc pprCode cs d = withPprStyle (PprCode cs) d diff --git a/ghc/compiler/utils/Pretty.lhs b/ghc/compiler/utils/Pretty.lhs index 1a3f70759c..6e2444860e 100644 --- a/ghc/compiler/utils/Pretty.lhs +++ b/ghc/compiler/utils/Pretty.lhs @@ -792,23 +792,12 @@ fillNB g p k ys = fill1 g p k ys ********************************************************* \begin{code} -best :: Mode - -> Int -- Line length +best :: Int -- Line length -> Int -- Ribbon length -> RDoc -> RDoc -- No unions in here! -best OneLineMode IBOX(w) IBOX(r) p - = get p - where - get Empty = Empty - get NoDoc = NoDoc - get (NilAbove p) = nilAbove_ (get p) - get (TextBeside s sl p) = textBeside_ s sl (get p) - get (Nest k p) = get p -- Elide nest - get (p `Union` q) = first (get p) (get q) - -best mode IBOX(w) IBOX(r) p +best IBOX(w) IBOX(r) p = get w p where get :: INT -- (Remaining) width of line @@ -858,7 +847,7 @@ minn x y | x LT y = x first p q | nonEmptySet p = p | otherwise = q -nonEmptySet NoDoc = False +nonEmptySet NoDoc = False nonEmptySet (p `Union` q) = True nonEmptySet Empty = True nonEmptySet (NilAbove p) = True -- NoDoc always in first line @@ -903,13 +892,30 @@ string_txt (PStr s1) s2 = _UNPK_ s1 ++ s2 \begin{code} -fullRender OneLineMode _ _ txt end doc = easy_display space_text txt end (reduceDoc doc) -fullRender LeftMode _ _ txt end doc = easy_display nl_text txt end (reduceDoc doc) +fullRender OneLineMode _ _ txt end doc + = lay (reduceDoc doc) + where + lay NoDoc = cant_fail + lay (Union p q) = (lay q) -- Second arg can't be NoDoc + lay (Nest k p) = lay p + lay Empty = end + lay (NilAbove p) = space_text `txt` lay p -- NoDoc always on first line + lay (TextBeside s sl p) = s `txt` lay p + +fullRender LeftMode _ _ txt end doc + = lay (reduceDoc doc) + where + lay NoDoc = cant_fail + lay (Union p q) = lay (first p q) + lay (Nest k p) = lay p + lay Empty = end + lay (NilAbove p) = nl_text `txt` lay p -- NoDoc always on first line + lay (TextBeside s sl p) = s `txt` lay p fullRender mode line_length ribbons_per_line txt end doc = display mode line_length ribbon_length txt end best_doc where - best_doc = best mode hacked_line_length ribbon_length (reduceDoc doc) + best_doc = best hacked_line_length ribbon_length (reduceDoc doc) hacked_line_length, ribbon_length :: Int ribbon_length = round (fromInt line_length / ribbons_per_line) @@ -951,15 +957,6 @@ display mode IBOX(page_width) IBOX(ribbon_width) txt end doc }} cant_fail = error "easy_display: NoDoc" -easy_display nl_text txt end doc - = lay doc cant_fail - where - lay NoDoc no_doc = no_doc - lay (Union p q) no_doc = {- lay p -} (lay q cant_fail) -- Second arg can't be NoDoc - lay (Nest k p) no_doc = lay p no_doc - lay Empty no_doc = end - lay (NilAbove p) no_doc = nl_text `txt` lay p cant_fail -- NoDoc always on first line - lay (TextBeside s sl p) no_doc = s `txt` lay p no_doc indent n | n GREQ ILIT(8) = '\t' : indent (n MINUS ILIT(8)) | otherwise = spaces n diff --git a/ghc/compiler/utils/Util.lhs b/ghc/compiler/utils/Util.lhs index 8e2198b050..2bb567db0a 100644 --- a/ghc/compiler/utils/Util.lhs +++ b/ghc/compiler/utils/Util.lhs @@ -28,7 +28,7 @@ module Util ( assoc, assocUsing, assocDefault, assocDefaultUsing, -- duplicate handling - hasNoDups, equivClasses, runs, removeDups, equivClassesByUniq, + hasNoDups, equivClasses, runs, removeDups, removeDupsEq, equivClassesByUniq, -- sorting IF_NOT_GHC(quicksort COMMA stableSortLt COMMA mergesort COMMA) @@ -364,6 +364,17 @@ removeDups cmp xs where collect_dups dups_so_far [x] = (dups_so_far, x) collect_dups dups_so_far dups@(x:xs) = (dups:dups_so_far, x) + +removeDupsEq :: Eq a => [a] -> ([a], [[a]]) +-- Same, but with only equality +-- It's worst case quadratic, but we only use it on short lists +removeDupsEq [] = ([], []) +removeDupsEq (x:xs) | x `elem` xs = (ys, (x : filter (== x) xs) : zs) + where + (ys,zs) = removeDupsEq (filter (/= x) xs) +removeDupsEq (x:xs) | otherwise = (x:ys, zs) + where + (ys,zs) = removeDupsEq xs \end{code} diff --git a/ghc/docs/users_guide/debugging.sgml b/ghc/docs/users_guide/debugging.sgml index 943315e4db..f711a382b8 100644 --- a/ghc/docs/users_guide/debugging.sgml +++ b/ghc/docs/users_guide/debugging.sgml @@ -204,6 +204,7 @@ renamer output </Para> </ListItem> </VarListEntry> + <VarListEntry> <Term><Option>-ddump-tc</Option>:</Term> <ListItem> @@ -212,6 +213,20 @@ typechecker output </Para> </ListItem> </VarListEntry> + +<VarListEntry> +<Term><Option>-ddump-types</Option>:</Term> +<ListItem> +<Para> +Dump a type signature for each value defined at the top level +of the module. The list is sorted alphabetically. +Using <Option>-dppr-debug</Option> dumps a type signature for +all the imported and system-defined things as well; useful +for debugging the compiler. +</Para> +</ListItem> +</VarListEntry> + <VarListEntry> <Term><Option>-ddump-deriv</Option>:</Term> <ListItem> diff --git a/ghc/driver/ghc-iface.lprl b/ghc/driver/ghc-iface.lprl deleted file mode 100644 index 32417017fb..0000000000 --- a/ghc/driver/ghc-iface.lprl +++ /dev/null @@ -1,377 +0,0 @@ -%************************************************************************ -%* * -\section[Driver-iface-thing]{Interface-file handling} -%* * -%************************************************************************ - -\begin{code} -%OldVersion = (); -%Decl = (); # details about individual definitions -%Stuff = (); # where we glom things together -%HiExists = ('old',-1, 'new',-1); # 1 <=> definitely exists; 0 <=> doesn't -%HiHasBeenRead = ('old', 0, 'new', 0); -%ModuleVersion = ('old', 0, 'new', 0); - -%HiSections = (); - -sub postprocessHiFile { - local($hsc_hi, # The iface info produced by hsc. - $hifile_target, # The name both of the .hi file we - # already have and which we *might* - # replace. - $going_interactive) = @_; - - local($new_hi) = "$Tmp_prefix.hi-new"; - local($show_hi_diffs) = $HiDiff_flag && ! $HiOnStdout && ! $going_interactive && -f $hifile_target; - - print STDERR "*** New hi file follows...\n" if $Verbose; - system("$Cat $hsc_hi 1>&2") if $Verbose; - - &constructNewHiFile($hsc_hi, *hifile_target, $new_hi, $show_hi_diffs); - - # run diff if they asked for it - if ($show_hi_diffs) { - if ( $HiDiff_flag eq 'usages' ) { - # lots of near-useless info; but if you want it... - &run_something("$Cmp -s $hifile_target $new_hi || $Diff $hifile_target $new_hi 1>&2 || exit 0", - "Diff'ing old and new .$HiSuffix files"); # NB: to stderr - } else { - # strip out usages, *then* run diff - local($hi_before) = "$Tmp_prefix.hi-before"; - local($hi_after) = "$Tmp_prefix.hi-now"; - - &deUsagifyHi($hifile_target, $hi_before); - &deUsagifyHi($new_hi, $hi_after); - - &run_something("$Cmp -s $hi_before $hi_after || $Diff $hi_before $hi_after 1>&2 || exit 0", - "Diff'ing old and new .$HiSuffix files"); # NB: to stderr - } - } - - # if we produced an interface file "no matter what", - # print what we got on stderr. - if ( $HiOnStdout ) { - if ( $HiWith ne '' ) { - # output some of the sections - local($hi_after) = "$Tmp_prefix.hi-now"; - - foreach $hi ( split(' ',$HiWith) ) { - $HiSection{$hi} = 1; - } - &hiSectionsOnly($new_hi, $hi_after); - - system("$Cat $hi_after 1>&2 ; $Rm $hi_after; "); - } else { - system("$Cat $new_hi 1>&2"); - } - } else { - &run_something("$Cmp -s $hifile_target $new_hi || ( $Rm $hifile_target && $Cp $new_hi $hifile_target )", - "Replace .$HiSuffix file, if changed"); - } -} - -sub deUsagifyHi { - local($ifile,$ofile) = @_; - - open(OLDHIF, "< $ifile") || &tidy_up_and_die(1,"Can't open $ifile (read)\n"); - open(NEWHIF, "> $ofile") || &tidy_up_and_die(1,"Can't open $ofile (write)\n"); - - # read up to _usages_ line - $_ = <OLDHIF>; - while ($_ ne '') { - print NEWHIF $_ unless /^(__interface|import)/; - $_ = <OLDHIF>; - } - - close(OLDHIF) || &tidy_up_and_die(1,"Failed reading from $ifile\n"); - close(NEWHIF) || &tidy_up_and_die(1,"Failed writing to $ofile\n"); -} -\end{code} - -\begin{code} -sub hiSectionsOnly { - local($ifile,$ofile) = @_; - - open(OLDHIF, "< $ifile") || &tidy_up_and_die(1,"Can't open $ifile (read)\n"); - open(NEWHIF, "> $ofile") || &tidy_up_and_die(1,"Can't open $ofile (write)\n"); - - # read up to _usages_ line - $_ = <OLDHIF>; - while ($_ ne '' ) { - if ( /^__export/ && $HiSection {'exports'} || - /^import / && $HiSection {'imports'} || - /^\d+ ([^ ]+ :: |type |data |class |newtype )/ && $HiSection {'declarations'} || - /^instance / && $HiSection {'instances'} ) { - print NEWHIF $_; - $_ = <OLDHIF>; - } else { - $_ = <OLDHIF>; - } - } - - close(OLDHIF) || &tidy_up_and_die(1,"Failed reading from $ifile\n"); - close(NEWHIF) || &tidy_up_and_die(1,"Failed writing to $ofile\n"); -} -\end{code} - -\begin{code} -sub constructNewHiFile { - local($hsc_hi, # The iface info produced by hsc. - *hifile_target, # Pre-existing .hi filename (if it exists) - $new_hi, # Filename for new one - $show_hi_diffs) = @_; - local($hiname,$hidir); - local($mod_name_dec); - - &readHiFile('new',$hsc_hi) unless $HiHasBeenRead{'new'} == 1; - - # Sigh, we need decode the module name found in the interface file - # since that's the (base)name we want to use when outputting the - # interface file. - $mod_name_dec = $ModuleName{'new'}; - $mod_name_dec =~ s/zz/z/g; - $mod_name_dec =~ s/ZZ/Z/g; - $mod_name_dec =~ s/zu/_/g; - - if ($Specific_hi_file eq '') { # -ohi is used even if module name != stem of filename. - ($hiname = $hifile_target) = $1 if $hifile_target =~ /\/?([^\/]+)\.$HiSuffix$/; - if ( $mod_name_dec ne $hiname ) { - $hidir = ''; - # strip off basename only if we've got a dirname. - ($hidir = $hifile_target) =~ s/(.*\/)[^\/]*$/$1/ - if ( $hifile_target =~ /\/$hiname\.$HiSuffix/ ); - $hifile_target = $hidir . $mod_name_dec . ".$HiSuffix"; - } - } - &readHiFile('old',$hifile_target) unless $HiHasBeenRead{'old'} == 1; - - open(NEWHI, "> $new_hi") || &tidy_up_and_die(1,"Can't open $new_hi (write)\n"); - - local(@decl_names) = (); # Declarations in new module - foreach $v (sort (keys %Decl)) { - next unless $v =~ /^new:(.*$)/; - push(@decl_names,$1); - } - - local($new_module_version) = &calcNewModuleVersion(@decl_names); - print NEWHI "__interface ", $PackageName{'new'}, $ModuleName{'new'}, " $new_module_version $Orphan{'new'} $ProjectVersionInt where\n"; - print NEWHI $Stuff{'new:exports'}; - print NEWHI $Stuff{'new:usages'} unless $Stuff{'new:usages'} eq ''; - print NEWHI $Stuff{'new:instances'} unless $Stuff{'new:instances'} eq ''; - - foreach $v (@decl_names) { - &printNewItemVersion(NEWHI, $v, $new_module_version, $show_hi_diffs); # Print new version number - print NEWHI $Decl{"new:$v"}; # Print the new decl itself - } - print NEWHI $Stuff{'new:rules'} unless $Stuff{'new:rules'} eq ''; - print NEWHI $Stuff{'new:deprecations'} unless $Stuff{'new:deprecations'} eq ''; - - close(NEWHI) || &tidy_up_and_die(1,"Failed writing to $new_hi\n"); -} -\end{code} - -Read the .hi file made by the compiler, or the old one. -All the declarations in the file are stored in - - $Decl{"$mod:$v"} - -where $mod is "new" or "old", depending on whether it's the new or old - .hi file that's being read. - -and $v is - for values v "v" - for tycons T "type T" or "data T" - for classes C "class C" - - -\begin{code} -sub readHiFile { - local($mod, # module to read; can be special tag 'old' - # (old .hi file for module being compiled) or - # 'new' (new proto-.hi file for...) - $hifile) = @_; # actual file to read - - # info about the old version of this module's interface - $HiExists{$mod} = -1; # 1 <=> definitely exists; 0 <=> doesn't - $HiHasBeenRead{$mod} = 0; - $ModuleVersion{$mod} = 0; - $Stuff{"$mod:usages"} = ''; # stuff glommed together - $Stuff{"$mod:exports"} = ''; - $Stuff{"$mod:instances"} = ''; - $Stuff{"$mod:declarations"} = ''; - $Stuff{"$mod:rules"} = ''; - $Stuff{"$mod:deprecations"} = ''; - - if (! -f $hifile) { # no pre-existing .hi file - $HiExists{$mod} = 0; - return(); - } - - open(HIFILE, "< $hifile") || &tidy_up_and_die(1,"Can't open $hifile (read)\n"); - $HiExists{$mod} = 1; - hi_line: while (<HIFILE>) { - next if /^ *$/; # blank line - - if ( /^__interface ("[A-Za-z]*"\s*)([A-Z]\S*)\s+(\d+)?\s*(\!)?/ ) { - if ( $mod ne 'new' ) { - # Reading old .hi file - $ModuleVersion{$mod} = $3; - } - - $PackageName{$mod} = $1; - $ModuleName{$mod} = $2; # used to decide name of iface file. - $Orphan{$mod} = $4; - # optional "!" indicates that the - # module contains orphan rules or instance decls - - } elsif ( /^import / ) { - $Stuff{"$mod:usages"} .= $_; # save the whole thing - - } elsif ( /^__export/ ) { - $Stuff{"$mod:exports"} .= $_; - - } elsif ( /^instance / ) { - $Stuff{"$mod:instances"} .= $_; - - } elsif ( /^{-## __R / ) { - $Stuff{"$mod:rules"} .= $_; - - } elsif ( /^{-## __D / ) { - $Stuff{"$mod:deprecations"} .= $_; - - } elsif ( /^-[-]+ .*/ ) { # silently ignore comment lines. - ; - } else { # We're in a declaration - - # Strip off the initial version number, if any - if ( /^([0-9]+)\s+(.*\n)/ ) { - - # The "\n" is because we need to keep the newline at - # the end, so that it looks the same as if there's no version - # number and this if statement doesn't fire. - - # So there's an initial version number - $version = $1; - $_ = $2; - } - - if ( /^type\s+(\S+)/ ) { - # Type declaration - $current_name = "type $1"; - $Decl{"$mod:$current_name"} = $_; - if ($mod eq "old") { $OldVersion{$current_name} = $version; } - - } elsif ( /^(newtype|data)\s+({.*}\s+=>\s+)?(\S+)\s+/ ) { - # Data declaration - # The (...)? parts skips over the context of a data decl - # to find the name of the type constructor. The curly - # brackets are part of the iface file syntax for contexts - $current_name = "data $3"; - $Decl{"$mod:$current_name"} = $_; - if ($mod eq "old") { $OldVersion{$current_name} = $version; } - - } elsif ( /^class\s+(\{[^{}]*\}\s+=>\s+)?(\S+)\s+/ ) { - # Class declaration - # must be wary of => bit matching after "where"... - # ..hence the [^{}] part - # NB: a class decl may not have a where part at all - $current_name = "class $2"; - $Decl{"$mod:$current_name"} = $_; - if ($mod eq "old") { $OldVersion{$current_name} = $version; } - - } elsif ( /^infix(r|l)?\s+[0-9]\s+(\S+)/ ) { - # fixity declaration - $current_name = "fixity $2"; - $Decl{"$mod:$current_name"} = $_; - if ($mod eq "old") { $OldVersion{$current_name} = $version; } - - } elsif ( /^(\S+)\s+::\s+/ ) { - # Value declaration - $current_name = $1; - $Decl{"$mod:$current_name"} = $_; - if ($mod eq "old") { $OldVersion{$current_name} = $version; } - - } else { # Continuation line - # print STDERR "$Pgm:junk old iface line?:$_"; - $Decl{"$mod:$current_name"} .= $_ - } - - } - } - - close(HIFILE) || &tidy_up_and_die(1,"Failed reading from $hifile\n"); - $HiHasBeenRead{$mod} = 1; -} -\end{code} - -\begin{code} -sub calcNewModuleVersion { - local (@decl_names) = @_; - - return(&mv_change(1,'no old .hi file')) if $HiExists{'old'} == 0; - # could use "time()" as initial version; if a module existed, then was deleted, - # then comes back, we don't want the resurrected one to have an - # lower version number than the original (in case there are any - # lingering references to the original in other .hi files). - - local($unchanged_version) = $ModuleVersion{'old'}; # will return one of these two - local($changed_version) = $unchanged_version + 1; - - if ($Orphan{'old'} ne $Orphan{'new'}) { - return(&mv_change($changed_version, "orphan-hood changed")); - } - - foreach $t ( 'usages' , 'exports', 'instances', 'fixities', 'rules', 'deprecations' ) { - return(&mv_change($changed_version,"$t changed")) if $Stuff{"old:$t"} ne $Stuff{"new:$t"}; - } - -# Decl need separate treatment; they aren't in $Stuff - foreach $v (@decl_names) { - return(&mv_change($changed_version,"$v changed")) if $Decl{"old:$v"} ne $Decl{"new:$v"}; - } - - print STDERR "$Pgm: module version unchanged at $unchanged_version\n" - if $Verbose; - return($unchanged_version); -} - -sub mv_change { - local($mv, $str) = @_; - - print STDERR "$Pgm: module version changed to $mv; reason: $str\n" - if $Verbose; - return($mv); -} - -sub printNewItemVersion { - local($hifile, $item, $mod_version, $show_hi_diffs) = @_; - local($idecl) = $Decl{"new:$item"}; - - - if (! defined($Decl{"old:$item"})) { # Old decl doesn't exist - if ($show_hi_diffs) {print STDERR "new: $item\n";} - print $hifile "$mod_version "; # Use module version - - } elsif (! defined($OldVersion{"$item"}) ) { - if ($show_hi_diffs) {print STDERR "$item: no old version?!\n";} - print $hifile "$mod_version "; # Use module version - - } elsif ($idecl ne $Decl{"old:$item"}) { # Old decl differs from new decl - local($odecl) = $Decl{"old:$item"}; - if ($show_hi_diffs) {print STDERR "changed: $item\nOld: $odecl", "New: $idecl";} - print $hifile "--old: ", $OldVersion{"$item"}, " $odecl" - if $Keep_HiDiffs; # show old in interface file - print $hifile "$mod_version "; # Use module version - - } else { # Identical decls, so use old version number - #if ($show_hi_diffs) {print STDERR "$item: unchanged\n";} - print $hifile $OldVersion{"$item"}, " "; - } - return; -} -\end{code} - -\begin{code} -# make "require"r happy... -1; -\end{code} diff --git a/ghc/driver/ghc.lprl b/ghc/driver/ghc.lprl index 7a59b7557c..bda22fca96 100644 --- a/ghc/driver/ghc.lprl +++ b/ghc/driver/ghc.lprl @@ -741,7 +741,7 @@ sub setupOptimiseFlags { # Specialisation is best done before full laziness # so that overloaded functions have all their dictionary lambdas manifest ($Oopt_DoSpecialise) ? ( $Oopt_DoSpecialise, ) : (), - '-ffloat-outwards', +# '-ffloat-outwards', '-ffloat-inwards', '-fsimplify', @@ -1502,7 +1502,7 @@ Now the Haskell compiler, C compiler, and assembler } if (-f $hsc_out_h_stub) { - &run_something("cp $hsc_out_h_stub $ofile_h_stub_target", 'Copy foreign export header file'); + &run_something("mv $hsc_out_h_stub $ofile_h_stub_target", 'Copy foreign export header file'); } if (-f $hsc_out_c_stub) { @@ -1684,7 +1684,7 @@ sub runHscAndProcessInterfaces { # See if it bailed out early, saying nothing needed doing. # We work this out by seeing if it created an output .hi file - if ( ! -f $hsc_hi && $ProduceHi !~ /-nohifile=/ ) { + if ( ! -f $hsc_out ) { # Doesn't exist, so we bailed out early. # Tell the C compiler and assembler not to run $do_cc = 0; $do_as = 0; @@ -1721,10 +1721,14 @@ sub runHscAndProcessInterfaces { # Interface-handling is important enough to live off by itself - if ( $ProduceHi !~ /-nohifile=/ ) { # If we've produced one, process it. - require('ghc-iface.prl') || &tidy_up_and_die(1,"$Pgm: panic: can't load ghc-iface.prl!\n"); - &postprocessHiFile($hsc_hi, $hifile_target, $going_interactive); + if ( -f $hsc_hi ) { + # print STDERR "Aha! A new hi file\n" ; + &run_something( "mv $hsc_hi $hifile_target", "Copy hi file" ) ; + } else { + # print STDERR "Oh ho! Hi file unchanged\n" ; } + + # if we're going to split up object files, # we inject split markers into the .hc file now if ( $HscLang eq 'C' && $SplitObjFiles ) { diff --git a/ghc/lib/std/Main.hi-boot b/ghc/lib/std/Main.hi-boot index d93b977f4f..844073fda0 100644 --- a/ghc/lib/std/Main.hi-boot +++ b/ghc/lib/std/Main.hi-boot @@ -8,6 +8,6 @@ __interface Main 1 where __export Main main ; -1 main :: __forall [a] => PrelIOBase.IO a; -- wish this could be __o. KSW 1999-04. +1 main :: __forall a => PrelIOBase.IO a; -- wish this could be __o. KSW 1999-04. diff --git a/ghc/lib/std/PrelErr.hi-boot b/ghc/lib/std/PrelErr.hi-boot index bd7f8f9f01..98d97219e9 100644 --- a/ghc/lib/std/PrelErr.hi-boot +++ b/ghc/lib/std/PrelErr.hi-boot @@ -7,6 +7,6 @@ -- because it's wired into the compiler --------------------------------------------------------------------------- -__interface PrelErr 2 0 where +__interface PrelErr 1 where __export PrelErr error parError; diff --git a/ghc/lib/std/PrelException.hi-boot b/ghc/lib/std/PrelException.hi-boot index 511010d4bf..9be1ea3779 100644 --- a/ghc/lib/std/PrelException.hi-boot +++ b/ghc/lib/std/PrelException.hi-boot @@ -5,8 +5,8 @@ -- for PrelException.hi. --------------------------------------------------------------------------- -__interface PrelException 1 0 where +__interface PrelException 1 where __export PrelException ioError catch; -1 ioError :: __forall [a] => PrelIOBase.IOError -> PrelIOBase.IO a ; -1 catch :: __forall [a] => PrelIOBase.IO a -> (PrelIOBase.IOError -> PrelIOBase.IO a) -> PrelIOBase.IO a ; -- wish there could be more __o's here. KSW 1999-04. +1 ioError :: __forall a => PrelIOBase.IOError -> PrelIOBase.IO a ; +1 catch :: __forall a => PrelIOBase.IO a -> (PrelIOBase.IOError -> PrelIOBase.IO a) -> PrelIOBase.IO a ; -- wish there could be more __o's here. KSW 1999-04. diff --git a/ghc/lib/std/PrelGHC.hi-boot b/ghc/lib/std/PrelGHC.hi-boot index bc7dac3927..dedb4de5ce 100644 --- a/ghc/lib/std/PrelGHC.hi-boot +++ b/ghc/lib/std/PrelGHC.hi-boot @@ -5,7 +5,7 @@ -- primitive operations and types that GHC knows about. --------------------------------------------------------------------------- -__interface "std" PrelGHC 2 0 where +__interface "std" PrelGHC 1 407 where __export PrelGHC @@ -341,6 +341,18 @@ __export PrelGHC unsafeCoercezh ; +-- Export PrelErr.error, so that others don't have to import PrelErr +__export PrelErr error ; + +-------------------------------------------------- +-- These imports tell modules low down in the hierarchy that +-- PrelErr and PrelBase are in the same package and +-- should be read from their hi-boot files +import PrelErr @ ; +import PrelNum @ ; + + +-------------------------------------------------- instance {CCallable Charzh} = zdfCCallableCharzh; instance {CCallable Doublezh} = zdfCCallableDoublezh; instance {CCallable Floatzh} = zdfCCallableFloatzh; @@ -350,15 +362,15 @@ instance {CCallable Int64zh} = zdfCCallableInt64zh; instance {CCallable Word64zh} = zdfCCallableWord64zh; instance {CCallable Wordzh} = zdfCCallableWordzh; instance {CCallable ByteArrayzh} = zdfCCallableByteArrayzh; -instance __forall [s] => {CCallable (MutableByteArrayzh s)} = zdfCCallableMutableByteArrayzh; +instance __forall s => {CCallable (MutableByteArrayzh s)} = zdfCCallableMutableByteArrayzh; instance {CCallable ForeignObjzh} = zdfCCallableForeignObjzh; -instance __forall [s] => {CCallable (StablePtrzh s)} = zdfCCallableStablePtrzh; +instance __forall s => {CCallable (StablePtrzh s)} = zdfCCallableStablePtrzh; -- CCallable and CReturnable have kind (Type AnyBox) so that -- things like Int# can be instances of CCallable. 1 class CCallable a :: ? ; 1 class CReturnable a :: ? ; -1 assert :: __forall [a] => PrelBase.Bool -> a -> a ; +1 assert :: __forall a => PrelBase.Bool -> a -> a ; -- These guys don't really exist: -- @@ -371,6 +383,6 @@ instance __forall [s] => {CCallable (StablePtrzh s)} = zdfCCallableStablePtrzh; 1 zdfCCallableWord64zh :: {CCallable Word64zh} ; 1 zdfCCallableWordzh :: {CCallable Wordzh} ; 1 zdfCCallableByteArrayzh :: {CCallable ByteArrayzh} ; -1 zdfCCallableMutableByteArrayzh :: __forall [s] => {CCallable (MutableByteArrayzh s)} ; +1 zdfCCallableMutableByteArrayzh :: __forall s => {CCallable (MutableByteArrayzh s)} ; 1 zdfCCallableForeignObjzh :: {CCallable ForeignObjzh} ; -1 zdfCCallableStablePtrzh :: __forall [a] => {CCallable (StablePtrzh a)} ; +1 zdfCCallableStablePtrzh :: __forall a => {CCallable (StablePtrzh a)} ; diff --git a/ghc/lib/std/PrelList.lhs b/ghc/lib/std/PrelList.lhs index 1ea90d6d13..dcc0c81b3c 100644 --- a/ghc/lib/std/PrelList.lhs +++ b/ghc/lib/std/PrelList.lhs @@ -21,7 +21,6 @@ module PrelList ( any, all, elem, notElem, lookup, maximum, minimum, concatMap, zip, zip3, zipWith, zipWith3, unzip, unzip3, - #ifdef USE_REPORT_PRELUDE #else @@ -483,6 +482,16 @@ foldr2_right k _z y r (x:xs) = k x y (r xs) #-} \end{code} +The foldr2/right rule isn't exactly right, because it changes +the strictness of foldr2 (and thereby zip) + +E.g. main = print (null (zip nonobviousNil (build undefined))) + where nonobviousNil = f 3 + f n = if n == 0 then [] else f (n-1) + +I'm going to leave it though. + + zip takes two lists and returns a list of corresponding pairs. If one input list is short, excess elements of the longer list are discarded. zip3 takes three lists and returns a list of triples. Zips for larger diff --git a/ghc/lib/std/PrelPack.hi-boot b/ghc/lib/std/PrelPack.hi-boot index 37908c8537..e7e6f6e550 100644 --- a/ghc/lib/std/PrelPack.hi-boot +++ b/ghc/lib/std/PrelPack.hi-boot @@ -7,7 +7,7 @@ -- other Prelude files that precede PrelPack --------------------------------------------------------------------------- -__interface PrelPack 1 where +__interface PrelPack 1 1 1 where __export PrelPack packCStringzh ; 1 packCStringzh :: [PrelBase.Char] -> PrelGHC.ByteArrayzh ; diff --git a/ghc/lib/std/PrelShow.lhs b/ghc/lib/std/PrelShow.lhs index 44e336482d..a2147ae40f 100644 --- a/ghc/lib/std/PrelShow.lhs +++ b/ghc/lib/std/PrelShow.lhs @@ -31,6 +31,7 @@ module PrelShow import {-# SOURCE #-} PrelErr ( error ) import PrelBase +import PrelTup import PrelMaybe import PrelList ( (!!), break, dropWhile #ifdef USE_REPORT_PRELUDE diff --git a/ghc/mk/version.mk b/ghc/mk/version.mk index cfda63ae77..7effb2dcb0 100644 --- a/ghc/mk/version.mk +++ b/ghc/mk/version.mk @@ -27,6 +27,12 @@ # ProjectVersionInt does *not* contain the patchlevel (rationale: this # figure is used for conditional compilations, and library interfaces # etc. are not supposed to change between patchlevels). +# +# The ProjectVersionInt is included in interface files, and GHC +# checks that it's reading interface generated by the same ProjectVersion +# as itself. It does this even though interface file syntax may not +# change between versions. Rationale: calling conventions or other +# random .o-file stuff might change even if the .hi syntax doesn't ProjectName = The Glorious Glasgow Haskell Compilation System ProjectNameShort = ghc @@ -48,14 +54,24 @@ HscMinorVersion=0 CcMajorVersion=36 CcMinorVersion=1 +# Interface file version (hi-boot files only) # -# Interface file version +# A GHC built with HscIfaceFileVersion=n will look for +# M.hi-boot-n, and only then for +# M.hi-boot. +# (It'll be happy with the latter if the former doesn't exist.) # -# If you should happen to make changes to the interface file format -# that will break compatibility with older versions, up this variable. -# +# This variable is used ONLY for hi-boot files. +# Its only purpose is to allow you to have a single directory +# with multiple .hi-boot files for the same module, each +# corresponding to a different version of GHC. +# +# It is propagated to hsc like this: +# * This file is included in ghc/Makefile +# * ghc/Makefile has a main/Constants.lhs-specific flag +# -DHscIfaceFileVersion=$(HscIfaceFileVersion) +# * main/Constants.lhs defines +# interfaceFileFormatVersion = HscIfaceFileVersion +# So there! + HscIfaceFileVersion=5 -# But watch out: interface file format after Simon's renamer -# hacking isn't the same as before, but it may not make -# any difference for the GHC boot files. -# May 1999 diff --git a/ghc/tests/typecheck/should_compile/tc105.hs b/ghc/tests/typecheck/should_compile/tc105.hs index f07fb0df19..891f2c7ab6 100644 --- a/ghc/tests/typecheck/should_compile/tc105.hs +++ b/ghc/tests/typecheck/should_compile/tc105.hs @@ -1,3 +1,5 @@ +{-# OPTIONS -fglasgow-exts #-}
+
-- !!! Scoped type variables in result signatures
module ShouldCompile where
|