diff options
Diffstat (limited to 'ghc/compiler')
150 files changed, 6701 insertions, 5692 deletions
diff --git a/ghc/compiler/HsVersions.h b/ghc/compiler/HsVersions.h index 0bd9c142c4..8852fd8adc 100644 --- a/ghc/compiler/HsVersions.h +++ b/ghc/compiler/HsVersions.h @@ -64,23 +64,16 @@ name = Util.global (value) :: IORef (ty); \ #define ASSERT(e) if (not (e)) then (assertPanic __FILE__ __LINE__) else #define ASSERT2(e,msg) if (not (e)) then (assertPprPanic __FILE__ __LINE__ (msg)) else #define WARN( e, msg ) (warnPprTrace (e) __FILE__ __LINE__ (msg)) -#define ASSERTM(e) ASSERT(e) do +#define ASSERTM(mbool) do { bool <- mbool; ASSERT(bool) return () } +#define ASSERTM2(mbool,msg) do { bool <- mbool; ASSERT2(bool,msg) return () } #else #define ASSERT(e) if False then error "ASSERT" else #define ASSERT2(e,msg) if False then error "ASSERT2" else #define ASSERTM(e) +#define ASSERTM2(e) #define WARN(e,msg) if False then error "WARN" else #endif --- temporary usage assertion control KSW 2000-10 -#ifdef DO_USAGES -#define UASSERT(e) ASSERT(e) -#define UASSERT2(e,msg) ASSERT2(e,msg) -#else -#define UASSERT(e) -#define UASSERT2(e,msg) -#endif - -- This #ifndef lets us switch off the "import FastString" -- when compiling FastString itself #ifndef COMPILING_FAST_STRING diff --git a/ghc/compiler/NOTES b/ghc/compiler/NOTES index 8607f90e51..e535959847 100644 --- a/ghc/compiler/NOTES +++ b/ghc/compiler/NOTES @@ -1,3 +1,6 @@ +*** unexpected failure for jtod_circint(opt) + + New back end thoughts ----------------------------------------------------------------------------- diff --git a/ghc/compiler/basicTypes/DataCon.hi-boot-6 b/ghc/compiler/basicTypes/DataCon.hi-boot-6 index 3fd253b9ed..7882469bce 100644 --- a/ghc/compiler/basicTypes/DataCon.hi-boot-6 +++ b/ghc/compiler/basicTypes/DataCon.hi-boot-6 @@ -2,4 +2,4 @@ module DataCon where data DataCon dataConName :: DataCon -> Name.Name -isExistentialDataCon :: DataCon -> GHC.Base.Bool +isVanillaDataCon :: DataCon -> GHC.Base.Bool diff --git a/ghc/compiler/basicTypes/DataCon.lhs b/ghc/compiler/basicTypes/DataCon.lhs index a209c73541..383fb752cb 100644 --- a/ghc/compiler/basicTypes/DataCon.lhs +++ b/ghc/compiler/basicTypes/DataCon.lhs @@ -9,39 +9,37 @@ module DataCon ( ConTag, fIRST_TAG, mkDataCon, dataConRepType, dataConSig, dataConName, dataConTag, dataConTyCon, - dataConArgTys, dataConOrigArgTys, dataConInstOrigArgTys, - dataConRepArgTys, dataConTheta, + dataConTyVars, dataConStupidTheta, + dataConArgTys, dataConOrigArgTys, + dataConInstOrigArgTys, dataConRepArgTys, dataConFieldLabels, dataConStrictMarks, dataConExStricts, dataConSourceArity, dataConRepArity, - dataConNumInstArgs, dataConIsInfix, + dataConIsInfix, dataConWorkId, dataConWrapId, dataConWrapId_maybe, dataConImplicitIds, dataConRepStrictness, - isNullaryDataCon, isTupleCon, isUnboxedTupleCon, - isExistentialDataCon, classDataCon, dataConExistentialTyVars, + isNullarySrcDataCon, isNullaryRepDataCon, isTupleCon, isUnboxedTupleCon, + isVanillaDataCon, classDataCon, splitProductType_maybe, splitProductType, ) where #include "HsVersions.h" -import {-# SOURCE #-} Subst( substTyWith ) - -import Type ( Type, ThetaType, +import Type ( Type, ThetaType, substTyWith, mkForAllTys, mkFunTys, mkTyConApp, - mkTyVarTys, splitTyConApp_maybe, + splitTyConApp_maybe, mkPredTys, isStrictPred, pprType ) -import TyCon ( TyCon, tyConDataCons, tyConDataCons, isProductTyCon, - isTupleTyCon, isUnboxedTupleTyCon ) +import TyCon ( TyCon, FieldLabel, tyConDataCons, tyConDataCons, + isProductTyCon, isTupleTyCon, isUnboxedTupleTyCon ) import Class ( Class, classTyCon ) import Name ( Name, NamedThing(..), nameUnique ) import Var ( TyVar, Id ) -import FieldLabel ( FieldLabel ) import BasicTypes ( Arity, StrictnessMark(..) ) import Outputable import Unique ( Unique, Uniquable(..) ) import ListSetOps ( assoc ) -import Util ( zipEqual, zipWithEqual, notNull ) +import Util ( zipEqual, zipWithEqual ) \end{code} @@ -138,23 +136,34 @@ I say the context is "stupid" because the dictionaries passed are immediately discarded -- they do nothing and have no benefit. It's a flaw in the language. -Up to now [March 2002] I have put this stupid context into the type of -the "wrapper" constructors functions, T1 and T2, but that turned out -to be jolly inconvenient for generics, and record update, and other -functions that build values of type T (because they don't have -suitable dictionaries available). + Up to now [March 2002] I have put this stupid context into the + type of the "wrapper" constructors functions, T1 and T2, but + that turned out to be jolly inconvenient for generics, and + record update, and other functions that build values of type T + (because they don't have suitable dictionaries available). + + So now I've taken the stupid context out. I simply deal with + it separately in the type checker on occurrences of a + constructor, either in an expression or in a pattern. -So now I've taken the stupid context out. I simply deal with it -separately in the type checker on occurrences of a constructor, either -in an expression or in a pattern. + [May 2003: actually I think this decision could evasily be + reversed now, and probably should be. Generics could be + disabled for types with a stupid context; record updates now + (H98) needs the context too; etc. It's an unforced change, so + I'm leaving it for now --- but it does seem odd that the + wrapper doesn't include the stupid context.] -[May 2003: actually I think this decision could evasily be reversed now, -and probably should be. Generics could be disabled for types with -a stupid context; record updates now (H98) needs the context too; etc. -It's an unforced change, so I'm leaving it for now --- but it does seem -odd that the wrapper doesn't include the stupid context.] +[July 04] With the advent of generalised data types, it's less obvious +what the "stupid context" is. Consider + C :: forall a. Ord a => a -> a -> T (Foo a) +Does the C constructor in Core contain the Ord dictionary? Yes, it must: + f :: T b -> Ordering + f = /\b. \x:T b. + case x of + C a (d:Ord a) (p:a) (q:a) -> compare d p q +Note that (Foo a) might not be an instance of Ord. %************************************************************************ %* * @@ -164,50 +173,41 @@ odd that the wrapper doesn't include the stupid context.] \begin{code} data DataCon - = MkData { -- Used for data constructors only; - -- there *is* no constructor for a newtype - + = MkData { dcName :: Name, -- This is the name of the *source data con* -- (see "Note [Data Constructor Naming]" above) - - dcUnique :: Unique, -- Cached from Name + dcUnique :: Unique, -- Cached from Name dcTag :: ConTag, -- Running example: -- -- data Eq a => T a = forall b. Ord b => MkT a [b] - dcRepType :: Type, -- Type of the constructor - -- forall a b . Ord b => a -> [b] -> MkT a - -- (this is *not* of the constructor wrapper Id: - -- see notes after this data type declaration) - -- - -- Notice that the existential type parameters come *second*. - -- Reason: in a case expression we may find: - -- case (e :: T t) of { MkT b (d:Ord b) (x:t) (xs:[b]) -> ... } - -- It's convenient to apply the rep-type of MkT to 't', to get - -- forall b. Ord b => ... - -- and use that to check the pattern. Mind you, this is really only - -- use in CoreLint. - - -- The next six fields express the type of the constructor, in pieces -- e.g. -- - -- dcTyVars = [a] - -- dcTheta = [Eq a] - -- dcExTyVars = [b] - -- dcExTheta = [Ord b] - -- dcOrigArgTys = [a,List b] - -- dcTyCon = T - - dcTyVars :: [TyVar], -- Type vars for the data type decl - -- These are ALWAYS THE SAME AS THE TYVARS - -- FOR THE PARENT TyCon. We occasionally rely on - -- this just to avoid redundant instantiation - - dcStupidTheta :: ThetaType, -- This is a "thinned" version of the context of - -- the data decl. + -- dcTyVars = [a,b] + -- dcStupidTheta = [Eq a] + -- dcTheta = [Ord b] + -- dcOrigArgTys = [a,List b] + -- dcTyCon = T + -- dcTyArgs = [a,b] + + dcVanilla :: Bool, -- True <=> This is a vanilla Haskell 98 data constructor + -- Its type is of form + -- forall a1..an . t1 -> ... tm -> T a1..an + -- No existentials, no GADTs, nothing. + + dcTyVars :: [TyVar], -- Universally-quantified type vars + -- for the data constructor. + -- dcVanilla = True <=> The [TyVar] are identical to those of the parent tycon + -- False <=> The [TyVar] are NOT NECESSARILY THE SAME AS THE TYVARS + -- FOR THE PARENT TyCon. (With GADTs the data + -- con might not even have the same number of + -- type variables.) + + dcStupidTheta :: ThetaType, -- This is a "thinned" version of + -- the context of the data decl. -- "Thinned", because the Report says -- to eliminate any constraints that don't mention -- tyvars free in the arg types for this constructor @@ -219,13 +219,16 @@ data DataCon -- that makes it harder to use the wrap-id to rebuild -- values after record selection or in generics. - dcExTyVars :: [TyVar], -- Ditto for the context of the constructor, - dcExTheta :: ThetaType, -- the existentially quantified stuff + dcTheta :: ThetaType, -- The existentially quantified stuff dcOrigArgTys :: [Type], -- Original argument types -- (before unboxing and flattening of -- strict fields) + -- Result type of constructor is T t1..tn + dcTyCon :: TyCon, -- Result tycon, T + dcResTys :: [Type], -- Result type args, t1..tn + -- Now the strictness annotations and field labels of the constructor dcStrictMarks :: [StrictnessMark], -- Strictness annotations as decided by the compiler. @@ -242,16 +245,27 @@ data DataCon -- after unboxing and flattening, -- and *including* existential dictionaries - dcRepStrictness :: [StrictnessMark], -- One for each representation argument + dcRepStrictness :: [StrictnessMark], -- One for each *representation* argument + + dcRepType :: Type, -- Type of the constructor + -- forall a b . Ord b => a -> [b] -> MkT a + -- (this is *not* of the constructor wrapper Id: + -- see notes after this data type declaration) + -- + -- Notice that the existential type parameters come *second*. + -- Reason: in a case expression we may find: + -- case (e :: T t) of { MkT b (d:Ord b) (x:t) (xs:[b]) -> ... } + -- It's convenient to apply the rep-type of MkT to 't', to get + -- forall b. Ord b => ... + -- and use that to check the pattern. Mind you, this is really only + -- use in CoreLint. - dcTyCon :: TyCon, -- Result tycon -- Finally, the curried worker function that corresponds to the constructor -- It doesn't have an unfolding; the code generator saturates these Ids -- and allocates a real constructor when it finds one. -- -- An entirely separate wrapper function is built in TcTyDecls - dcIds :: DataConIds, dcInfix :: Bool -- True <=> declared infix @@ -347,29 +361,28 @@ instance Show DataCon where \begin{code} mkDataCon :: Name -> Bool -- Declared infix + -> Bool -- Vanilla (see notes with dcVanilla) -> [StrictnessMark] -> [FieldLabel] - -> [TyVar] -> ThetaType - -> [TyVar] -> ThetaType - -> [Type] -> TyCon + -> [TyVar] -> ThetaType -> ThetaType + -> [Type] -> TyCon -> [Type] -> DataConIds -> DataCon -- Can get the tag from the TyCon -mkDataCon name declared_infix +mkDataCon name declared_infix vanilla arg_stricts -- Must match orig_arg_tys 1-1 fields - tyvars theta ex_tyvars ex_theta orig_arg_tys tycon + tyvars stupid_theta theta orig_arg_tys tycon res_tys ids = con where con = MkData {dcName = name, - dcUnique = nameUnique name, - dcTyVars = tyvars, dcStupidTheta = theta, - dcOrigArgTys = orig_arg_tys, + dcUnique = nameUnique name, dcVanilla = vanilla, + dcTyVars = tyvars, dcStupidTheta = stupid_theta, dcTheta = theta, + dcOrigArgTys = orig_arg_tys, dcTyCon = tycon, dcResTys = res_tys, dcRepArgTys = rep_arg_tys, - dcExTyVars = ex_tyvars, dcExTheta = ex_theta, dcStrictMarks = arg_stricts, dcRepStrictness = rep_arg_stricts, - dcFields = fields, dcTag = tag, dcTyCon = tycon, dcRepType = ty, + dcFields = fields, dcTag = tag, dcRepType = ty, dcIds = ids, dcInfix = declared_infix} -- Strictness marks for source-args @@ -379,19 +392,18 @@ mkDataCon name declared_infix -- The 'arg_stricts' passed to mkDataCon are simply those for the -- source-language arguments. We add extra ones for the -- dictionary arguments right here. - ex_dict_tys = mkPredTys ex_theta - real_arg_tys = ex_dict_tys ++ orig_arg_tys - real_stricts = map mk_dict_strict_mark ex_theta ++ arg_stricts + dict_tys = mkPredTys theta + real_arg_tys = dict_tys ++ orig_arg_tys + real_stricts = map mk_dict_strict_mark theta ++ arg_stricts -- Representation arguments and demands (rep_arg_stricts, rep_arg_tys) = computeRep real_stricts real_arg_tys tag = assoc "mkDataCon" (tyConDataCons tycon `zip` [fIRST_TAG..]) con - ty = mkForAllTys (tyvars ++ ex_tyvars) - (mkFunTys rep_arg_tys result_ty) + ty = mkForAllTys tyvars (mkFunTys rep_arg_tys result_ty) -- NB: the existential dict args are already in rep_arg_tys - result_ty = mkTyConApp tycon (mkTyVarTys tyvars) + result_ty = mkTyConApp tycon res_tys mk_dict_strict_mark pred | isStrictPred pred = MarkedStrict | otherwise = NotMarkedStrict @@ -413,6 +425,9 @@ dataConRepType = dcRepType dataConIsInfix :: DataCon -> Bool dataConIsInfix = dcInfix +dataConTyVars :: DataCon -> [TyVar] +dataConTyVars = dcTyVars + dataConWorkId :: DataCon -> Id dataConWorkId dc = case dcIds dc of AlgDC _ wrk_id -> wrk_id @@ -445,12 +460,7 @@ dataConStrictMarks = dcStrictMarks dataConExStricts :: DataCon -> [StrictnessMark] -- Strictness of *existential* arguments only -- Usually empty, so we don't bother to cache this -dataConExStricts dc = map mk_dict_strict_mark (dcExTheta dc) - --- Number of type-instantiation arguments --- All the remaining arguments of the DataCon are (notionally) --- stored in the DataCon, and are matched in a case expression -dataConNumInstArgs (MkData {dcTyVars = tyvars}) = length tyvars +dataConExStricts dc = map mk_dict_strict_mark (dcTheta dc) dataConSourceArity :: DataCon -> Arity -- Source-level arity of the data constructor @@ -462,7 +472,9 @@ dataConSourceArity dc = length (dcOrigArgTys dc) -- dictionaries dataConRepArity (MkData {dcRepArgTys = arg_tys}) = length arg_tys -isNullaryDataCon con = dataConRepArity con == 0 +isNullarySrcDataCon, isNullaryRepDataCon :: DataCon -> Bool +isNullarySrcDataCon dc = null (dcOrigArgTys dc) +isNullaryRepDataCon dc = null (dcRepArgTys dc) dataConRepStrictness :: DataCon -> [StrictnessMark] -- Give the demands on the arguments of a @@ -470,13 +482,11 @@ dataConRepStrictness :: DataCon -> [StrictnessMark] dataConRepStrictness dc = dcRepStrictness dc dataConSig :: DataCon -> ([TyVar], ThetaType, - [TyVar], ThetaType, - [Type], TyCon) + [Type], TyCon, [Type]) -dataConSig (MkData {dcTyVars = tyvars, dcStupidTheta = theta, - dcExTyVars = ex_tyvars, dcExTheta = ex_theta, - dcOrigArgTys = arg_tys, dcTyCon = tycon}) - = (tyvars, theta, ex_tyvars, ex_theta, arg_tys, tycon) +dataConSig (MkData {dcTyVars = tyvars, dcTheta = theta, + dcOrigArgTys = arg_tys, dcTyCon = tycon, dcResTys = res_tys}) + = (tyvars, theta, arg_tys, tycon, res_tys) dataConArgTys :: DataCon -> [Type] -- Instantiated at these types @@ -485,23 +495,18 @@ dataConArgTys :: DataCon -- NB: these INCLUDE the existentially quantified dict args -- but EXCLUDE the data-decl context which is discarded -- It's all post-flattening etc; this is a representation type +dataConArgTys (MkData {dcRepArgTys = arg_tys, dcTyVars = tyvars}) inst_tys + = map (substTyWith tyvars inst_tys) arg_tys -dataConArgTys (MkData {dcRepArgTys = arg_tys, dcTyVars = tyvars, - dcExTyVars = ex_tyvars}) inst_tys - = map (substTyWith (tyvars ++ ex_tyvars) inst_tys) arg_tys - -dataConTheta :: DataCon -> ThetaType -dataConTheta dc = dcStupidTheta dc - -dataConExistentialTyVars :: DataCon -> [TyVar] -dataConExistentialTyVars dc = dcExTyVars dc - --- And the same deal for the original arg tys: - +-- And the same deal for the original arg tys +-- This one only works for vanilla DataCons dataConInstOrigArgTys :: DataCon -> [Type] -> [Type] -dataConInstOrigArgTys (MkData {dcOrigArgTys = arg_tys, dcTyVars = tyvars, - dcExTyVars = ex_tyvars}) inst_tys - = map (substTyWith (tyvars ++ ex_tyvars) inst_tys) arg_tys +dataConInstOrigArgTys (MkData {dcOrigArgTys = arg_tys, dcTyVars = tyvars, dcVanilla = is_vanilla}) inst_tys + = ASSERT( is_vanilla ) + map (substTyWith tyvars inst_tys) arg_tys + +dataConStupidTheta :: DataCon -> ThetaType +dataConStupidTheta dc = dcStupidTheta dc \end{code} These two functions get the real argument types of the constructor, @@ -528,8 +533,8 @@ isTupleCon (MkData {dcTyCon = tc}) = isTupleTyCon tc isUnboxedTupleCon :: DataCon -> Bool isUnboxedTupleCon (MkData {dcTyCon = tc}) = isUnboxedTupleTyCon tc -isExistentialDataCon :: DataCon -> Bool -isExistentialDataCon (MkData {dcExTyVars = tvs}) = notNull tvs +isVanillaDataCon :: DataCon -> Bool +isVanillaDataCon dc = dcVanilla dc \end{code} diff --git a/ghc/compiler/basicTypes/Id.lhs b/ghc/compiler/basicTypes/Id.lhs index 4b7f131634..ae3c103972 100644 --- a/ghc/compiler/basicTypes/Id.lhs +++ b/ghc/compiler/basicTypes/Id.lhs @@ -90,6 +90,7 @@ import Var ( Id, DictId, globalIdDetails ) import qualified Var ( mkLocalId, mkGlobalId, mkSpecPragmaId, mkExportedLocalId ) +import TyCon ( FieldLabel, TyCon ) import Type ( Type, typePrimRep, addFreeTyVars, seqType, splitTyConApp_maybe, PrimRep ) import TysPrim ( statePrimTyCon ) @@ -106,7 +107,6 @@ import Name ( Name, OccName, nameIsLocalOrFrom, ) import Module ( Module ) import OccName ( EncodedFS, mkWorkerOcc ) -import FieldLabel ( FieldLabel ) import Maybes ( orElse ) import SrcLoc ( SrcLoc ) import Outputable @@ -239,13 +239,13 @@ Meanwhile, it is not discarded as dead code. \begin{code} -recordSelectorFieldLabel :: Id -> FieldLabel +recordSelectorFieldLabel :: Id -> (TyCon, FieldLabel) recordSelectorFieldLabel id = case globalIdDetails id of - RecordSelId lbl -> lbl + RecordSelId tycon lbl -> (tycon,lbl) other -> panic "recordSelectorFieldLabel" isRecordSelector id = case globalIdDetails id of - RecordSelId lbl -> True + RecordSelId _ _ -> True other -> False isPrimOpId id = case globalIdDetails id of @@ -290,7 +290,7 @@ isImplicitId :: Id -> Bool -- file, even if it's mentioned in some other interface unfolding. isImplicitId id = case globalIdDetails id of - RecordSelId _ -> True + RecordSelId _ _ -> True FCallId _ -> True PrimOpId _ -> True ClassOpId _ -> True diff --git a/ghc/compiler/basicTypes/IdInfo.lhs b/ghc/compiler/basicTypes/IdInfo.lhs index f4cb7062e1..54578ae2f4 100644 --- a/ghc/compiler/basicTypes/IdInfo.lhs +++ b/ghc/compiler/basicTypes/IdInfo.lhs @@ -87,8 +87,8 @@ import BasicTypes ( OccInfo(..), isFragileOcc, isDeadOcc, seqOccInfo, isLoopBrea Activation(..) ) import DataCon ( DataCon ) +import TyCon ( TyCon, FieldLabel ) import ForeignCall ( ForeignCall ) -import FieldLabel ( FieldLabel ) import NewDemand import Outputable import Maybe ( isJust ) @@ -230,7 +230,8 @@ an IdInfo.hi-boot, but no Id.hi-boot, and GlobalIdDetails is imported data GlobalIdDetails = VanillaGlobal -- Imported from elsewhere, a default method Id. - | RecordSelId FieldLabel -- The Id for a record selector + | RecordSelId TyCon FieldLabel -- The Id for a record selector + | DataConWorkId DataCon -- The Id for a data constructor *worker* | DataConWrapId DataCon -- The Id for a data constructor *wrapper* -- [the only reasons we need to know is so that @@ -255,7 +256,7 @@ instance Outputable GlobalIdDetails where ppr (ClassOpId _) = ptext SLIT("[ClassOp]") ppr (PrimOpId _) = ptext SLIT("[PrimOp]") ppr (FCallId _) = ptext SLIT("[ForeignCall]") - ppr (RecordSelId _) = ptext SLIT("[RecSel]") + ppr (RecordSelId _ _) = ptext SLIT("[RecSel]") \end{code} diff --git a/ghc/compiler/basicTypes/Literal.lhs b/ghc/compiler/basicTypes/Literal.lhs index 01b21b12ee..5a3608bb3e 100644 --- a/ghc/compiler/basicTypes/Literal.lhs +++ b/ghc/compiler/basicTypes/Literal.lhs @@ -7,7 +7,7 @@ module Literal ( Literal(..) -- Exported to ParseIface , mkMachInt, mkMachWord - , mkMachInt64, mkMachWord64 + , mkMachInt64, mkMachWord64, mkStringLit, , litSize , litIsDupable, litIsTrivial , literalType, @@ -35,6 +35,7 @@ import FastTypes import FastString import Binary +import UnicodeUtil ( stringToUtf8 ) import Ratio ( numerator ) import FastString ( uniqueOfFS, lengthFS ) import DATA_INT ( Int8, Int16, Int32 ) @@ -204,6 +205,9 @@ mkMachWord x = -- ASSERT2( inWordRange x, integer x ) mkMachInt64 x = MachInt64 x mkMachWord64 x = MachWord64 x +mkStringLit :: String -> Literal +mkStringLit s = MachStr (mkFastString (stringToUtf8 s)) + inIntRange, inWordRange :: Integer -> Bool inIntRange x = x >= tARGET_MIN_INT && x <= tARGET_MAX_INT inWordRange x = x >= 0 && x <= tARGET_MAX_WORD diff --git a/ghc/compiler/basicTypes/MkId.lhs b/ghc/compiler/basicTypes/MkId.lhs index dcd057d205..ddca1e8e93 100644 --- a/ghc/compiler/basicTypes/MkId.lhs +++ b/ghc/compiler/basicTypes/MkId.lhs @@ -52,22 +52,22 @@ import TcType ( Type, ThetaType, mkDictTy, mkPredTys, mkTyConApp, ) import CoreUtils ( exprType ) import CoreUnfold ( mkTopUnfolding, mkCompulsoryUnfolding, mkOtherCon ) -import Literal ( Literal(..), nullAddrLit ) +import Literal ( nullAddrLit, mkStringLit ) import TyCon ( TyCon, isNewTyCon, tyConTyVars, tyConDataCons, - tyConTheta, isProductTyCon, isDataTyCon, isRecursiveTyCon ) -import Class ( Class, classTyCon, classTyVars, classSelIds ) + tyConStupidTheta, isProductTyCon, isDataTyCon, isRecursiveTyCon ) +import Class ( Class, classTyCon, classSelIds ) import Var ( Id, TyVar, Var ) import VarSet ( isEmptyVarSet ) import Name ( mkFCallName, mkWiredInName, Name, BuiltInSyntax(..) ) import OccName ( mkOccFS, varName ) import PrimOp ( PrimOp, primOpSig, primOpOcc, primOpTag ) import ForeignCall ( ForeignCall ) -import DataCon ( DataCon, DataConIds(..), +import DataCon ( DataCon, DataConIds(..), dataConTyVars, dataConFieldLabels, dataConRepArity, - dataConArgTys, dataConRepType, - dataConOrigArgTys, dataConTheta, + dataConRepArgTys, dataConRepType, + dataConStupidTheta, dataConOrigArgTys, dataConSig, dataConStrictMarks, dataConExStricts, - splitProductType + splitProductType, isVanillaDataCon ) import Id ( idType, mkGlobalId, mkVanillaGlobal, mkSysLocal, mkTemplateLocals, mkTemplateLocalsNum, mkExportedLocalId, @@ -81,9 +81,6 @@ import IdInfo ( IdInfo, noCafIdInfo, setUnfoldingInfo, import NewDemand ( mkStrictSig, DmdResult(..), mkTopDmdType, topDmd, evalDmd, lazyDmd, retCPR, Demand(..), Demands(..) ) -import FieldLabel ( fieldLabelName, firstFieldLabelTag, - allFieldLabelTags, fieldLabelType - ) import DmdAnal ( dmdAnalTopRhs ) import CoreSyn import Unique ( mkBuiltinUnique, mkPrimOpIdUnique ) @@ -94,7 +91,6 @@ import Util ( dropList, isSingleton ) import Outputable import FastString import ListSetOps ( assoc, assocMaybe ) -import UnicodeUtil ( stringToUtf8 ) import List ( nubBy ) \end{code} @@ -200,14 +196,13 @@ mkDataConIds wrap_name wkr_name data_con | otherwise -- Algebraic, no wrapper = AlgDC Nothing wrk_id where - (tyvars, _, ex_tyvars, ex_theta, orig_arg_tys, tycon) = dataConSig data_con - all_tyvars = tyvars ++ ex_tyvars + (tyvars, theta, orig_arg_tys, tycon, res_tys) = dataConSig data_con - ex_dict_tys = mkPredTys ex_theta - all_arg_tys = ex_dict_tys ++ orig_arg_tys - result_ty = mkTyConApp tycon (mkTyVarTys tyvars) + dict_tys = mkPredTys theta + all_arg_tys = dict_tys ++ orig_arg_tys + result_ty = mkTyConApp tycon res_tys - wrap_ty = mkForAllTys all_tyvars (mkFunTys all_arg_tys result_ty) + wrap_ty = mkForAllTys tyvars (mkFunTys all_arg_tys result_ty) -- We used to include the stupid theta in the wrapper's args -- but now we don't. Instead the type checker just injects these -- extra constraints where necessary. @@ -251,8 +246,8 @@ mkDataConIds wrap_name wkr_name data_con nt_wrap_info = noCafIdInfo -- The NoCaf-ness is set by noCafIdInfo `setArityInfo` 1 -- Arity 1 `setUnfoldingInfo` newtype_unf - newtype_unf = ASSERT( null ex_tyvars && null ex_theta && - isSingleton orig_arg_tys ) + newtype_unf = ASSERT( isVanillaDataCon data_con && + isSingleton orig_arg_tys ) -- No existentials on a newtype, but it can have a context -- e.g. newtype Eq a => T a = MkT (...) mkTopUnfolding $ Note InlineMe $ @@ -285,18 +280,18 @@ mkDataConIds wrap_name wkr_name data_con -- we want to see that w is strict in its two arguments alg_unf = mkTopUnfolding $ Note InlineMe $ - mkLams all_tyvars $ - mkLams ex_dict_args $ mkLams id_args $ + mkLams tyvars $ + mkLams dict_args $ mkLams id_args $ foldr mk_case con_app - (zip (ex_dict_args ++ id_args) all_strict_marks) + (zip (dict_args ++ id_args) all_strict_marks) i3 [] con_app i rep_ids = mkApps (Var wrk_id) - (map varToCoreExpr (all_tyvars ++ reverse rep_ids)) + (map varToCoreExpr (tyvars ++ reverse rep_ids)) - (ex_dict_args,i2) = mkLocals 1 ex_dict_tys - (id_args,i3) = mkLocals i2 orig_arg_tys - alg_arity = i3-1 + (dict_args,i2) = mkLocals 1 dict_tys + (id_args,i3) = mkLocals i2 orig_arg_tys + alg_arity = i3-1 mk_case :: (Id, StrictnessMark) -- Arg, strictness @@ -310,12 +305,14 @@ mkDataConIds wrap_name wkr_name data_con MarkedStrict | isUnLiftedType (idType arg) -> body i (arg:rep_args) | otherwise -> - Case (Var arg) arg [(DEFAULT,[], body i (arg:rep_args))] +-- gaw 2004 + Case (Var arg) arg result_ty [(DEFAULT,[], body i (arg:rep_args))] MarkedUnboxed -> case splitProductType "do_unbox" (idType arg) of (tycon, tycon_args, con, tys) -> - Case (Var arg) arg [(DataAlt con, con_args, +-- gaw 2004 + Case (Var arg) arg result_ty [(DataAlt con, con_args, body i' (reverse con_args ++ rep_args))] where (con_args, i') = mkLocals i tys @@ -382,12 +379,11 @@ Similarly for (recursive) newtypes unN = /\b -> \n:N -> (coerce (forall a. a->a) n) \begin{code} -mkRecordSelId tycon field_label +mkRecordSelId tycon field_label field_ty -- Assumes that all fields with the same field label have the same type = sel_id where - sel_id = mkGlobalId (RecordSelId field_label) (fieldLabelName field_label) selector_ty info - field_ty = fieldLabelType field_label + sel_id = mkGlobalId (RecordSelId tycon field_label) field_label selector_ty info data_cons = tyConDataCons tycon tyvars = tyConTyVars tycon -- These scope over the types in -- the FieldLabels of constructors of this type @@ -405,9 +401,7 @@ mkRecordSelId tycon field_label -- -- NB: this code relies on the fact that DataCons are quantified over -- the identical type variables as their parent TyCon - tycon_theta = tyConTheta tycon -- The context on the data decl - -- eg data (Eq a, Ord b) => T a b = ... - needed_preds = [pred | (DataAlt dc, _, _) <- the_alts, pred <- dataConTheta dc] + needed_preds = [pred | (DataAlt dc, _, _) <- the_alts, pred <- dataConStupidTheta dc] dict_tys = map mkPredTy (nubBy tcEqPred needed_preds) n_dict_tys = length dict_tys @@ -447,16 +441,17 @@ mkRecordSelId tycon field_label `setAllStrictnessInfo` Just strict_sig -- Allocate Ids. We do it a funny way round because field_dict_tys is - -- almost always empty. Also note that we use length_tycon_theta + -- almost always empty. Also note that we use max_dict_tys -- rather than n_dict_tys, because the latter gives an infinite loop: -- n_dict tys depends on the_alts, which depens on arg_ids, which depends -- on arity, which depends on n_dict tys. Sigh! Mega sigh! - field_dict_base = length tycon_theta + 1 - dict_id_base = field_dict_base + n_field_dict_tys - field_base = dict_id_base + 1 - dict_ids = mkTemplateLocalsNum 1 dict_tys - field_dict_ids = mkTemplateLocalsNum field_dict_base field_dict_tys - data_id = mkTemplateLocal dict_id_base data_ty + dict_ids = mkTemplateLocalsNum 1 dict_tys + max_dict_tys = length (tyConStupidTheta tycon) + field_dict_base = max_dict_tys + 1 + field_dict_ids = mkTemplateLocalsNum field_dict_base field_dict_tys + dict_id_base = field_dict_base + n_field_dict_tys + data_id = mkTemplateLocal dict_id_base data_ty + arg_base = dict_id_base + 1 alts = map mk_maybe_alt data_cons the_alts = catMaybes alts @@ -474,7 +469,7 @@ mkRecordSelId tycon field_label Lam data_id $ sel_body sel_body | isNewTyCon tycon = mk_result (mkNewTypeBody tycon field_ty (Var data_id)) - | otherwise = Case (Var data_id) data_id (default_alt ++ the_alts) + | otherwise = Case (Var data_id) data_id field_tau (default_alt ++ the_alts) mk_result poly_result = mkVarApps (mkVarApps poly_result field_tyvars) field_dict_ids -- We pull the field lambdas to the top, so we need to @@ -487,18 +482,17 @@ mkRecordSelId tycon field_label mk_maybe_alt data_con = case maybe_the_arg_id of Nothing -> Nothing - Just the_arg_id -> Just (mkReboxingAlt uniqs data_con arg_ids body) - where - body = mk_result (Var the_arg_id) + Just the_arg_id -> Just (mkReboxingAlt uniqs data_con arg_ids $ + mk_result (Var the_arg_id)) where - arg_ids = mkTemplateLocalsNum field_base (dataConOrigArgTys data_con) - -- No need to instantiate; same tyvars in datacon as tycon - -- Records can't be existential, so no existential tyvars or dicts + arg_ids = ASSERT( isVanillaDataCon data_con ) + mkTemplateLocalsNum arg_base (dataConOrigArgTys data_con) + -- Records can't be existential, so no existential tyvars or dicts + -- Vanilla data con => tycon's tyvars will do - unpack_base = field_base + length arg_ids + unpack_base = arg_base + length arg_ids uniqs = map mkBuiltinUnique [unpack_base..] - -- arity+1 avoids all shadowing maybe_the_arg_id = assocMaybe (field_lbls `zip` arg_ids) field_label field_lbls = dataConFieldLabels data_con @@ -602,8 +596,6 @@ mkDictSelId name clas -- But it's type must expose the representation of the dictionary -- to gat (say) C a -> (a -> a) - tag = assoc "MkId.mkDictSelId" (map idName (classSelIds clas) `zip` allFieldLabelTags) name - info = noCafIdInfo `setArityInfo` 1 `setUnfoldingInfo` mkTopUnfolding rhs @@ -621,21 +613,19 @@ mkDictSelId name clas | otherwise = Eval (Prod [ if the_arg_id == id then evalDmd else Abs | id <- arg_ids ]) - tyvars = classTyVars clas - tycon = classTyCon clas [data_con] = tyConDataCons tycon - tyvar_tys = mkTyVarTys tyvars - arg_tys = dataConArgTys data_con tyvar_tys - the_arg_id = arg_ids !! (tag - firstFieldLabelTag) + tyvars = dataConTyVars data_con + arg_tys = dataConRepArgTys data_con + the_arg_id = assoc "MkId.mkDictSelId" (map idName (classSelIds clas) `zip` arg_ids) name - pred = mkClassPred clas tyvar_tys + pred = mkClassPred clas (mkTyVarTys tyvars) (dict_id:arg_ids) = mkTemplateLocals (mkPredTy pred : arg_tys) rhs | isNewTyCon tycon = mkLams tyvars $ Lam dict_id $ mkNewTypeBody tycon (head arg_tys) (Var dict_id) | otherwise = mkLams tyvars $ Lam dict_id $ - Case (Var dict_id) dict_id + Case (Var dict_id) dict_id (idType the_arg_id) [(DataAlt data_con, arg_ids, Var the_arg_id)] mkNewTypeBody tycon result_ty result_expr @@ -760,7 +750,7 @@ mkDictFunId dfun_name inst_tyvars dfun_theta clas inst_tys (class_tyvars, sc_theta, _, _) = classBigSig clas not_const (clas, tys) = not (isEmptyVarSet (tyVarsOfTypes tys)) - sc_theta' = substClasses (mkTopTyVarSubst class_tyvars inst_tys) sc_theta + sc_theta' = substClasses (zipTopTvSubst class_tyvars inst_tys) sc_theta dfun_theta = case inst_decl_theta of [] -> [] -- If inst_decl_theta is empty, then we don't -- want to have any dict arguments, so that we can @@ -860,7 +850,8 @@ seqId ty = mkForAllTys [alphaTyVar,openBetaTyVar] (mkFunTy alphaTy (mkFunTy openBetaTy openBetaTy)) [x,y] = mkTemplateLocals [alphaTy, openBetaTy] - rhs = mkLams [alphaTyVar,openBetaTyVar,x,y] (Case (Var x) x [(DEFAULT, [], Var y)]) +-- gaw 2004 + rhs = mkLams [alphaTyVar,openBetaTyVar,x,y] (Case (Var x) x openBetaTy [(DEFAULT, [], Var y)]) -- lazy :: forall a?. a? -> a? (i.e. works for unboxed types too) -- Used to lazify pseq: pseq a b = a `seq` lazy b @@ -936,7 +927,7 @@ mkRuntimeErrorApp mkRuntimeErrorApp err_id res_ty err_msg = mkApps (Var err_id) [Type res_ty, err_string] where - err_string = Lit (MachStr (mkFastString (stringToUtf8 err_msg))) + err_string = Lit (mkStringLit err_msg) rEC_SEL_ERROR_ID = mkRuntimeErrorId recSelErrorName rUNTIME_ERROR_ID = mkRuntimeErrorId runtimeErrorName diff --git a/ghc/compiler/basicTypes/Name.lhs b/ghc/compiler/basicTypes/Name.lhs index b39c4028d3..c440369916 100644 --- a/ghc/compiler/basicTypes/Name.lhs +++ b/ghc/compiler/basicTypes/Name.lhs @@ -326,37 +326,40 @@ pprName (Name {n_sort = sort, n_uniq = uniq, n_occ = occ}) Internal -> pprInternal sty uniq occ pprExternal sty uniq mod occ is_wired is_builtin - | codeStyle sty = ppr mod_name <> char '_' <> pprOccName occ + | codeStyle sty = ppr mod_name <> char '_' <> ppr_occ_name occ -- In code style, always qualify -- ToDo: maybe we could print all wired-in things unqualified -- in code style, to reduce symbol table bloat? - | debugStyle sty = sep [ppr mod_name <> dot <> pprOccName occ, - hsep [text "{-" - , if is_wired then ptext SLIT("(w)") else empty - , pprUnique uniq --- (overkill) , case mb_p of --- Nothing -> empty --- Just n -> brackets (ppr n) - , text "-}"]] - | BuiltInSyntax <- is_builtin = pprOccName occ + | debugStyle sty = ppr mod_name <> dot <> ppr_occ_name occ + <> braces (hsep [if is_wired then ptext SLIT("(w)") else empty, + text (briefOccNameFlavour occ), + pprUnique uniq]) + | BuiltInSyntax <- is_builtin = ppr_occ_name occ -- never qualify builtin syntax - | unqualStyle sty mod_name occ = pprOccName occ - | otherwise = ppr mod_name <> dot <> pprOccName occ + | unqualStyle sty mod_name occ = ppr_occ_name occ + | otherwise = ppr mod_name <> dot <> ppr_occ_name occ where mod_name = moduleName mod pprInternal sty uniq occ | codeStyle sty = pprUnique uniq - | debugStyle sty = pprOccName occ <> text "{-" <> pprUnique uniq <> text "-}" - | otherwise = pprOccName occ -- User style + | debugStyle sty = ppr_occ_name occ <> braces (hsep [text (briefOccNameFlavour occ), + pprUnique uniq]) + | otherwise = ppr_occ_name occ -- User style -- Like Internal, except that we only omit the unique in Iface style pprSystem sty uniq occ | codeStyle sty = pprUnique uniq - | otherwise = pprOccName occ <> char '_' <> pprUnique uniq + | debugStyle sty = ppr_occ_name occ <> char '_' <> pprUnique uniq + <> braces (text (briefOccNameFlavour occ)) + | otherwise = ppr_occ_name occ <> char '_' <> pprUnique uniq -- If the tidy phase hasn't run, the OccName -- is unlikely to be informative (like 's'), -- so print the unique + +ppr_occ_name occ = pprEncodedFS (occNameFS occ) + -- Don't use pprOccName; instead, just print the string of the OccName; + -- we print the namespace in the debug stuff above \end{code} %************************************************************************ diff --git a/ghc/compiler/basicTypes/Var.lhs b/ghc/compiler/basicTypes/Var.lhs index 350986ed46..d02b9ecf30 100644 --- a/ghc/compiler/basicTypes/Var.lhs +++ b/ghc/compiler/basicTypes/Var.lhs @@ -13,7 +13,7 @@ module Var ( TyVar, mkTyVar, mkTcTyVar, tyVarName, tyVarKind, setTyVarName, setTyVarUnique, - tcTyVarRef, tcTyVarDetails, + tcTyVarDetails, -- Ids Id, DictId, @@ -34,9 +34,8 @@ module Var ( #include "HsVersions.h" import {-# SOURCE #-} TypeRep( Type ) -import {-# SOURCE #-} TcType( TyVarDetails ) -import {-# SOURCE #-} IdInfo( GlobalIdDetails, notGlobalId, - IdInfo, seqIdInfo ) +import {-# SOURCE #-} TcType( TcTyVarDetails ) +import {-# SOURCE #-} IdInfo( GlobalIdDetails, notGlobalId, IdInfo, seqIdInfo ) import Name ( Name, OccName, NamedThing(..), setNameUnique, setNameOcc, nameUnique @@ -45,7 +44,6 @@ import Kind ( Kind ) import Unique ( Unique, Uniquable(..), mkUniqueGrimily, getKey# ) import FastTypes import Outputable -import DATA_IOREF \end{code} @@ -71,11 +69,10 @@ data Var tyVarKind :: Kind } | TcTyVar { -- Used only during type inference - varName :: !Name, -- Could we get away without a Name? + varName :: !Name, realUnique :: FastInt, tyVarKind :: Kind, - tcTyVarRef :: IORef (Maybe Type), - tcTyVarDetails :: TyVarDetails } + tcTyVarDetails :: TcTyVarDetails } | GlobalId { -- Used for imported Ids, dict selectors etc varName :: !Name, @@ -180,12 +177,11 @@ mkTyVar name kind = TyVar { varName = name , tyVarKind = kind } -mkTcTyVar :: Name -> Kind -> TyVarDetails -> IORef (Maybe Type) -> TyVar -mkTcTyVar name kind details ref +mkTcTyVar :: Name -> Kind -> TcTyVarDetails -> TyVar +mkTcTyVar name kind details = TcTyVar { varName = name, realUnique = getKey# (nameUnique name), tyVarKind = kind, - tcTyVarRef = ref, tcTyVarDetails = details } \end{code} diff --git a/ghc/compiler/basicTypes/VarEnv.lhs b/ghc/compiler/basicTypes/VarEnv.lhs index d219fe5508..3c7f7f0c6b 100644 --- a/ghc/compiler/basicTypes/VarEnv.lhs +++ b/ghc/compiler/basicTypes/VarEnv.lhs @@ -7,112 +7,140 @@ module VarEnv ( VarEnv, IdEnv, TyVarEnv, emptyVarEnv, unitVarEnv, mkVarEnv, - elemVarEnv, rngVarEnv, + elemVarEnv, varEnvElts, extendVarEnv, extendVarEnv_C, extendVarEnvList, plusVarEnv, plusVarEnv_C, delVarEnvList, delVarEnv, lookupVarEnv, lookupVarEnv_NF, lookupWithDefaultVarEnv, mapVarEnv, zipVarEnv, modifyVarEnv, modifyVarEnv_Directly, - isEmptyVarEnv, foldVarEnv, + isEmptyVarEnv, foldVarEnv, + lookupVarEnv_Directly, + filterVarEnv_Directly, - -- TidyEnvs - TidyEnv, emptyTidyEnv, + -- InScopeSet + InScopeSet, emptyInScopeSet, mkInScopeSet, delInScopeSet, + extendInScopeSet, extendInScopeSetList, modifyInScopeSet, + getInScopeVars, lookupInScope, elemInScopeSet, uniqAway, - -- SubstEnvs - SubstEnv, TyVarSubstEnv, SubstResult(..), - emptySubstEnv, substEnvEnv, elemSubstEnv, - mkSubstEnv, lookupSubstEnv, extendSubstEnv, extendSubstEnvList, - delSubstEnv, delSubstEnvList, noTypeSubst, isEmptySubstEnv + -- TidyEnvs + TidyEnv, emptyTidyEnv ) where #include "HsVersions.h" -import {-# SOURCE #-} CoreSyn( CoreExpr ) -import {-# SOURCE #-} TypeRep( Type ) - -import BasicTypes ( OccInfo ) import OccName ( TidyOccEnv, emptyTidyOccEnv ) -import Var ( Var, Id ) +import Var ( Var, setVarUnique ) +import VarSet import UniqFM +import Unique ( Unique, deriveUnique, getUnique ) import Util ( zipEqual ) +import CmdLineOpts ( opt_PprStyle_Debug ) +import Outputable +import FastTypes \end{code} %************************************************************************ %* * -\subsection{Tidying} + In-scope sets %* * %************************************************************************ -When tidying up print names, we keep a mapping of in-scope occ-names -(the TidyOccEnv) and a Var-to-Var of the current renamings. - \begin{code} -type TidyEnv = (TidyOccEnv, VarEnv Var) +data InScopeSet = InScope (VarEnv Var) FastInt + -- The Int# is a kind of hash-value used by uniqAway + -- For example, it might be the size of the set + -- INVARIANT: it's not zero; we use it as a multiplier in uniqAway + +instance Outputable InScopeSet where + ppr (InScope s i) = ptext SLIT("InScope") <+> ppr s + +emptyInScopeSet :: InScopeSet +emptyInScopeSet = InScope emptyVarSet 1# + +getInScopeVars :: InScopeSet -> VarEnv Var +getInScopeVars (InScope vs _) = vs + +mkInScopeSet :: VarEnv Var -> InScopeSet +mkInScopeSet in_scope = InScope in_scope 1# + +extendInScopeSet :: InScopeSet -> Var -> InScopeSet +extendInScopeSet (InScope in_scope n) v = InScope (extendVarEnv in_scope v v) (n +# 1#) + +extendInScopeSetList :: InScopeSet -> [Var] -> InScopeSet +extendInScopeSetList (InScope in_scope n) vs + = InScope (foldl (\s v -> extendVarEnv s v v) in_scope vs) + (n +# iUnbox (length vs)) + +modifyInScopeSet :: InScopeSet -> Var -> Var -> InScopeSet +-- Exploit the fact that the in-scope "set" is really a map +-- Make old_v map to new_v +modifyInScopeSet (InScope in_scope n) old_v new_v = InScope (extendVarEnv in_scope old_v new_v) (n +# 1#) + +delInScopeSet :: InScopeSet -> Var -> InScopeSet +delInScopeSet (InScope in_scope n) v = InScope (in_scope `delVarEnv` v) n + +elemInScopeSet :: Var -> InScopeSet -> Bool +elemInScopeSet v (InScope in_scope n) = v `elemVarEnv` in_scope + +lookupInScope :: InScopeSet -> Var -> Maybe Var +-- It's important to look for a fixed point +-- When we see (case x of y { I# v -> ... }) +-- we add [x -> y] to the in-scope set (Simplify.simplCaseBinder). +-- When we lookup up an occurrence of x, we map to y, but then +-- we want to look up y in case it has acquired more evaluation information by now. +lookupInScope (InScope in_scope n) v + = go v + where + go v = case lookupVarEnv in_scope v of + Just v' | v == v' -> Just v' -- Reached a fixed point + | otherwise -> go v' + Nothing -> Nothing +\end{code} -emptyTidyEnv :: TidyEnv -emptyTidyEnv = (emptyTidyOccEnv, emptyVarEnv) +\begin{code} +uniqAway :: InScopeSet -> Var -> Var +-- (uniqAway in_scope v) finds a unique that is not used in the +-- in-scope set, and gives that to v. It starts with v's current unique, of course, +-- in the hope that it won't have to change it, and thereafter uses a combination +-- of that and the hash-code found in the in-scope set +uniqAway (InScope set n) var + | not (var `elemVarSet` set) = var -- Nothing to do + | otherwise = try 1# + where + orig_unique = getUnique var + try k +#ifdef DEBUG + | k ># 1000# + = pprPanic "uniqAway loop:" (ppr (iBox k) <+> text "tries" <+> ppr var <+> int (iBox n)) +#endif + | uniq `elemVarSetByKey` set = try (k +# 1#) +#ifdef DEBUG + | opt_PprStyle_Debug && k ># 3# + = pprTrace "uniqAway:" (ppr (iBox k) <+> text "tries" <+> ppr var <+> int (iBox n)) + setVarUnique var uniq +#endif + | otherwise = setVarUnique var uniq + where + uniq = deriveUnique orig_unique (iBox (n *# k)) \end{code} %************************************************************************ %* * -\subsection{Substitution environments} + Tidying %* * %************************************************************************ -\begin{code} - -noTys :: SubstResult -> Bool -> Bool -noTys (DoneTy ty) no_tys = False -noTys other no_tys = no_tys - -data SubstEnv = SE (VarEnv SubstResult) - Bool -- True => definitely no type substitutions in the env - -noTypeSubst :: SubstEnv -> Bool -noTypeSubst (SE _ nt) = nt - -substEnvEnv :: SubstEnv -> VarEnv SubstResult -substEnvEnv (SE env _) = env - -type TyVarSubstEnv = SubstEnv -- of the form (DoneTy ty) *only* - -data SubstResult - = DoneEx CoreExpr -- Completed term - | DoneId Id OccInfo -- Completed term variable, with occurrence info; only - -- used by the simplifier - | DoneTy Type -- Completed type - | ContEx SubstEnv CoreExpr -- A suspended substitution - -emptySubstEnv :: SubstEnv -emptySubstEnv = SE emptyVarEnv True - -isEmptySubstEnv :: SubstEnv -> Bool -isEmptySubstEnv (SE s _) = isEmptyVarEnv s - -lookupSubstEnv :: SubstEnv -> Var -> Maybe SubstResult -lookupSubstEnv (SE s _) v = lookupVarEnv s v - -elemSubstEnv :: Var -> SubstEnv -> Bool -elemSubstEnv v (SE s _) = elemVarEnv v s - -extendSubstEnv :: SubstEnv -> Var -> SubstResult -> SubstEnv -extendSubstEnv (SE s nt) v r = SE (extendVarEnv s v r) (noTys r nt) - -mkSubstEnv :: [Var] -> [SubstResult] -> SubstEnv -mkSubstEnv bs vs = extendSubstEnvList emptySubstEnv bs vs - -extendSubstEnvList :: SubstEnv -> [Var] -> [SubstResult] -> SubstEnv -extendSubstEnvList env [] [] = env -extendSubstEnvList (SE env nt) (b:bs) (r:rs) = extendSubstEnvList (SE (extendVarEnv env b r) (noTys r nt)) bs rs +When tidying up print names, we keep a mapping of in-scope occ-names +(the TidyOccEnv) and a Var-to-Var of the current renamings. -delSubstEnv :: SubstEnv -> Var -> SubstEnv -delSubstEnv (SE s nt) v = SE (delVarEnv s v) nt +\begin{code} +type TidyEnv = (TidyOccEnv, VarEnv Var) -delSubstEnvList :: SubstEnv -> [Var] -> SubstEnv -delSubstEnvList (SE s nt) vs = SE (delVarEnvList s vs) nt +emptyTidyEnv :: TidyEnv +emptyTidyEnv = (emptyTidyOccEnv, emptyVarEnv) \end{code} @@ -136,12 +164,14 @@ extendVarEnv_C :: (a->a->a) -> VarEnv a -> Var -> a -> VarEnv a plusVarEnv :: VarEnv a -> VarEnv a -> VarEnv a extendVarEnvList :: VarEnv a -> [(Var, a)] -> VarEnv a +lookupVarEnv_Directly :: VarEnv a -> Unique -> Maybe a +filterVarEnv_Directly :: (Unique -> a -> Bool) -> VarEnv a -> VarEnv a delVarEnvList :: VarEnv a -> [Var] -> VarEnv a delVarEnv :: VarEnv a -> Var -> VarEnv a plusVarEnv_C :: (a -> a -> a) -> VarEnv a -> VarEnv a -> VarEnv a mapVarEnv :: (a -> b) -> VarEnv a -> VarEnv b modifyVarEnv :: (a -> a) -> VarEnv a -> Var -> VarEnv a -rngVarEnv :: VarEnv a -> [a] +varEnvElts :: VarEnv a -> [a] isEmptyVarEnv :: VarEnv a -> Bool lookupVarEnv :: VarEnv a -> Var -> Maybe a @@ -165,10 +195,12 @@ lookupWithDefaultVarEnv = lookupWithDefaultUFM mapVarEnv = mapUFM mkVarEnv = listToUFM emptyVarEnv = emptyUFM -rngVarEnv = eltsUFM +varEnvElts = eltsUFM unitVarEnv = unitUFM isEmptyVarEnv = isNullUFM foldVarEnv = foldUFM +lookupVarEnv_Directly = lookupUFM_Directly +filterVarEnv_Directly = filterUFM_Directly zipVarEnv tyvars tys = mkVarEnv (zipEqual "zipVarEnv" tyvars tys) lookupVarEnv_NF env id = case (lookupVarEnv env id) of { Just xx -> xx } diff --git a/ghc/compiler/basicTypes/VarSet.lhs b/ghc/compiler/basicTypes/VarSet.lhs index 5971964f41..55e82a8515 100644 --- a/ghc/compiler/basicTypes/VarSet.lhs +++ b/ghc/compiler/basicTypes/VarSet.lhs @@ -13,7 +13,8 @@ module VarSet ( intersectVarSet, intersectsVarSet, isEmptyVarSet, delVarSet, delVarSetList, delVarSetByKey, minusVarSet, foldVarSet, filterVarSet, - lookupVarSet, mapVarSet, sizeVarSet, seqVarSet + lookupVarSet, mapVarSet, sizeVarSet, seqVarSet, + elemVarSetByKey ) where #include "HsVersions.h" @@ -59,6 +60,7 @@ filterVarSet :: (Var -> Bool) -> VarSet -> VarSet extendVarSet_C :: (Var->Var->Var) -> VarSet -> Var -> VarSet delVarSetByKey :: VarSet -> Unique -> VarSet +elemVarSetByKey :: Unique -> VarSet -> Bool emptyVarSet = emptyUniqSet unitVarSet = unitUniqSet @@ -87,6 +89,7 @@ sizeVarSet = sizeUniqSet filterVarSet = filterUniqSet extendVarSet_C combine s x = addToUFM_C combine s x x delVarSetByKey = delFromUFM_Directly -- Can't be bothered to add this to UniqSet +elemVarSetByKey = elemUniqSet_Directly \end{code} \begin{code} diff --git a/ghc/compiler/codeGen/CgBindery.lhs b/ghc/compiler/codeGen/CgBindery.lhs index 0f858777c2..5a953500a0 100644 --- a/ghc/compiler/codeGen/CgBindery.lhs +++ b/ghc/compiler/codeGen/CgBindery.lhs @@ -258,9 +258,9 @@ cgLookupPanic id pprPanic "cgPanic" (vcat [ppr id, ptext SLIT("static binds for:"), - vcat [ ppr (cg_id info) | info <- rngVarEnv static_binds ], + vcat [ ppr (cg_id info) | info <- varEnvElts static_binds ], ptext SLIT("local binds for:"), - vcat [ ppr (cg_id info) | info <- rngVarEnv local_binds ], + vcat [ ppr (cg_id info) | info <- varEnvElts local_binds ], ptext SLIT("SRT label") <+> pprCLabel srt ]) \end{code} @@ -277,7 +277,7 @@ we don't leave any (NoVolatile, NoStable) binds around... \begin{code} nukeVolatileBinds :: CgBindings -> CgBindings nukeVolatileBinds binds - = mkVarEnv (foldr keep_if_stable [] (rngVarEnv binds)) + = mkVarEnv (foldr keep_if_stable [] (varEnvElts binds)) where keep_if_stable (CgIdInfo { cg_stb = NoStableLoc }) acc = acc keep_if_stable info acc @@ -443,7 +443,7 @@ nukeDeadBindings live_vars = do let (dead_stk_slots, bs') = dead_slots live_vars [] [] - [ (cg_id b, b) | b <- rngVarEnv binds ] + [ (cg_id b, b) | b <- varEnvElts binds ] setBinds $ mkVarEnv bs' freeStackSlots dead_stk_slots \end{code} @@ -486,6 +486,6 @@ getLiveStackSlots :: FCode [VirtualSpOffset] getLiveStackSlots = do { binds <- getBinds ; return [off | CgIdInfo { cg_stb = VirStkLoc off, - cg_rep = rep } <- rngVarEnv binds, + cg_rep = rep } <- varEnvElts binds, isFollowableArg rep] } \end{code} diff --git a/ghc/compiler/codeGen/CgCase.lhs b/ghc/compiler/codeGen/CgCase.lhs index bdcc5ff17c..bdacd27ebd 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.70 2004/08/13 13:25:45 simonmar Exp $ +% $Id: CgCase.lhs,v 1.71 2004/09/30 10:35:36 simonpj Exp $ % %******************************************************** %* * diff --git a/ghc/compiler/codeGen/CgClosure.lhs b/ghc/compiler/codeGen/CgClosure.lhs index dc5e9eae35..0c6ca4b76f 100644 --- a/ghc/compiler/codeGen/CgClosure.lhs +++ b/ghc/compiler/codeGen/CgClosure.lhs @@ -1,7 +1,7 @@ % % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % -% $Id: CgClosure.lhs,v 1.63 2004/08/13 13:05:54 simonmar Exp $ +% $Id: CgClosure.lhs,v 1.64 2004/09/30 10:35:39 simonpj Exp $ % \section[CgClosure]{Code generation for closures} diff --git a/ghc/compiler/codeGen/CgCon.lhs b/ghc/compiler/codeGen/CgCon.lhs index 6b3b36abaa..7dc5d75b41 100644 --- a/ghc/compiler/codeGen/CgCon.lhs +++ b/ghc/compiler/codeGen/CgCon.lhs @@ -45,7 +45,7 @@ import CostCentre ( currentOrSubsumedCCS, dontCareCCS, CostCentreStack, currentCCS ) import Constants ( mIN_INTLIKE, mAX_INTLIKE, mIN_CHARLIKE, mAX_CHARLIKE ) import TyCon ( TyCon, tyConDataCons, isEnumerationTyCon, tyConName ) -import DataCon ( DataCon, dataConRepArgTys, isNullaryDataCon, +import DataCon ( DataCon, dataConRepArgTys, isNullaryRepDataCon, isUnboxedTupleCon, dataConWorkId, dataConName, dataConRepArity ) @@ -404,7 +404,7 @@ static closure, for a constructor. cgDataCon :: DataCon -> Code cgDataCon data_con = do { -- Don't need any dynamic closure code for zero-arity constructors - whenC (not (isNullaryDataCon data_con)) + whenC (not (isNullaryRepDataCon data_con)) (emit_info dyn_cl_info tickyEnterDynCon) -- Dynamic-Closure first, to reduce forward references diff --git a/ghc/compiler/codeGen/CgExpr.lhs b/ghc/compiler/codeGen/CgExpr.lhs index d72c7c5a4c..ff405319c4 100644 --- a/ghc/compiler/codeGen/CgExpr.lhs +++ b/ghc/compiler/codeGen/CgExpr.lhs @@ -1,7 +1,7 @@ % % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % -% $Id: CgExpr.lhs,v 1.59 2004/08/13 13:05:58 simonmar Exp $ +% $Id: CgExpr.lhs,v 1.60 2004/09/30 10:35:43 simonpj Exp $ % %******************************************************** %* * diff --git a/ghc/compiler/codeGen/CgHeapery.lhs b/ghc/compiler/codeGen/CgHeapery.lhs index 6abffe72dc..5e6c122f7c 100644 --- a/ghc/compiler/codeGen/CgHeapery.lhs +++ b/ghc/compiler/codeGen/CgHeapery.lhs @@ -1,7 +1,7 @@ % % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % -% $Id: CgHeapery.lhs,v 1.40 2004/08/13 13:06:00 simonmar Exp $ +% $Id: CgHeapery.lhs,v 1.41 2004/09/30 10:35:45 simonpj Exp $ % \section[CgHeapery]{Heap management functions} diff --git a/ghc/compiler/codeGen/CgLetNoEscape.lhs b/ghc/compiler/codeGen/CgLetNoEscape.lhs index 3ea05974f6..39860f4ee0 100644 --- a/ghc/compiler/codeGen/CgLetNoEscape.lhs +++ b/ghc/compiler/codeGen/CgLetNoEscape.lhs @@ -1,7 +1,7 @@ % % (c) The GRASP/AQUA Project, Glasgow University, 1993-1998 % -% $Id: CgLetNoEscape.lhs,v 1.25 2004/08/13 13:06:03 simonmar Exp $ +% $Id: CgLetNoEscape.lhs,v 1.26 2004/09/30 10:35:47 simonpj Exp $ % %******************************************************** %* * diff --git a/ghc/compiler/codeGen/CgProf.hs b/ghc/compiler/codeGen/CgProf.hs index 30f801dba3..0c2381b14a 100644 --- a/ghc/compiler/codeGen/CgProf.hs +++ b/ghc/compiler/codeGen/CgProf.hs @@ -389,9 +389,9 @@ emitSetCCC :: CostCentre -> Code emitSetCCC cc | not opt_SccProfilingOn = nopC | otherwise = do - ASSERTM(sccAbleCostCentre cc) tmp <- newTemp wordRep - pushCostCentre tmp curCCS cc + ASSERT( sccAbleCostCentre cc ) + pushCostCentre tmp curCCS cc stmtC (CmmStore curCCSAddr (CmmReg tmp)) when (isSccCountCostCentre cc) $ stmtC (bumpSccCount curCCS) diff --git a/ghc/compiler/codeGen/CgStackery.lhs b/ghc/compiler/codeGen/CgStackery.lhs index 2dddb3d34f..7cb310d521 100644 --- a/ghc/compiler/codeGen/CgStackery.lhs +++ b/ghc/compiler/codeGen/CgStackery.lhs @@ -1,7 +1,7 @@ % % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % -% $Id: CgStackery.lhs,v 1.26 2004/08/17 15:23:48 simonpj Exp $ +% $Id: CgStackery.lhs,v 1.27 2004/09/30 10:35:49 simonpj Exp $ % \section[CgStackery]{Stack management functions} diff --git a/ghc/compiler/codeGen/CgTailCall.lhs b/ghc/compiler/codeGen/CgTailCall.lhs index 982891b2f7..98c075d31d 100644 --- a/ghc/compiler/codeGen/CgTailCall.lhs +++ b/ghc/compiler/codeGen/CgTailCall.lhs @@ -1,7 +1,7 @@ % % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % -% $Id: CgTailCall.lhs,v 1.39 2004/08/13 13:06:13 simonmar Exp $ +% $Id: CgTailCall.lhs,v 1.40 2004/09/30 10:35:50 simonpj Exp $ % %******************************************************** %* * diff --git a/ghc/compiler/codeGen/ClosureInfo.lhs b/ghc/compiler/codeGen/ClosureInfo.lhs index 0abf831c51..476aa2aa95 100644 --- a/ghc/compiler/codeGen/ClosureInfo.lhs +++ b/ghc/compiler/codeGen/ClosureInfo.lhs @@ -65,7 +65,7 @@ import CmdLineOpts ( opt_SccProfilingOn, opt_OmitBlackHoling, opt_Parallel, opt_DoTickyProfiling, opt_SMP ) import Id ( Id, idType, idArity, idName ) -import DataCon ( DataCon, dataConTyCon, isNullaryDataCon, dataConName ) +import DataCon ( DataCon, dataConTyCon, isNullaryRepDataCon, dataConName ) import Name ( Name, nameUnique, getOccName, getOccString ) import OccName ( occNameUserString ) import Type ( isUnLiftedType, Type, repType, splitTyConApp_maybe ) @@ -663,7 +663,7 @@ staticClosureNeedsLink :: ClosureInfo -> Bool staticClosureNeedsLink (ClosureInfo { closureSRT = srt }) = needsSRT srt staticClosureNeedsLink (ConInfo { closureSMRep = sm_rep, closureCon = con }) - = not (isNullaryDataCon con) && not_nocaf_constr + = not (isNullaryRepDataCon con) && not_nocaf_constr where not_nocaf_constr = case sm_rep of diff --git a/ghc/compiler/codeGen/CodeGen.lhs b/ghc/compiler/codeGen/CodeGen.lhs index d7f2f70c43..7ee581a45f 100644 --- a/ghc/compiler/codeGen/CodeGen.lhs +++ b/ghc/compiler/codeGen/CodeGen.lhs @@ -53,7 +53,7 @@ import OccName ( mkLocalOcc ) import TyCon ( isDataTyCon ) import Module ( Module, mkModuleName ) import ErrUtils ( dumpIfSet_dyn, showPass ) -import Panic ( assertPanic, trace ) +import Panic ( assertPanic ) import qualified Module ( moduleName ) #ifdef DEBUG diff --git a/ghc/compiler/coreSyn/CoreFVs.lhs b/ghc/compiler/coreSyn/CoreFVs.lhs index 384add20e6..6aed662c6b 100644 --- a/ghc/compiler/coreSyn/CoreFVs.lhs +++ b/ghc/compiler/coreSyn/CoreFVs.lhs @@ -127,8 +127,10 @@ expr_fvs (Note _ expr) = expr_fvs expr expr_fvs (App fun arg) = expr_fvs fun `union` expr_fvs arg expr_fvs (Lam bndr body) = addBndr bndr (expr_fvs body) -expr_fvs (Case scrut bndr alts) - = expr_fvs scrut `union` addBndr bndr (foldr (union . alt_fvs) noVars alts) +-- gaw 2004 +expr_fvs (Case scrut bndr ty alts) + = expr_fvs scrut `union` someVars (tyVarsOfType ty) `union` addBndr bndr + (foldr (union . alt_fvs) noVars alts) where alt_fvs (con, bndrs, rhs) = addBndrs bndrs (expr_fvs rhs) @@ -179,8 +181,10 @@ exprFreeNames (Let (Rec prs) e) = (exprsFreeNames rs `unionNameSets` exprFreeNam where (bs, rs) = unzip prs -exprFreeNames (Case e b as) = exprFreeNames e `unionNameSets` - (unionManyNameSets (map altFreeNames as) `delFromNameSet` varName b) +-- gaw 2004 +exprFreeNames (Case e b ty as) = exprFreeNames e `unionNameSets` tyClsNamesOfType ty + `unionNameSets` + (unionManyNameSets (map altFreeNames as) `delFromNameSet` varName b) -- Helpers altFreeNames (_,bs,r) = exprFreeNames r `del_binders` bs @@ -321,9 +325,10 @@ freeVars (App fun arg) fun2 = freeVars fun arg2 = freeVars arg -freeVars (Case scrut bndr alts) - = ((bndr `delBinderFV` alts_fvs) `unionFVs` freeVarsOf scrut2, - AnnCase scrut2 bndr alts2) +freeVars (Case scrut bndr ty alts) +-- gaw 2004 + = ((bndr `delBinderFV` alts_fvs) `unionFVs` freeVarsOf scrut2 `unionFVs` tyVarsOfType ty, + AnnCase scrut2 bndr ty alts2) where scrut2 = freeVars scrut diff --git a/ghc/compiler/coreSyn/CoreLint.lhs b/ghc/compiler/coreSyn/CoreLint.lhs index a9a5362504..5e088e4ae3 100644 --- a/ghc/compiler/coreSyn/CoreLint.lhs +++ b/ghc/compiler/coreSyn/CoreLint.lhs @@ -15,26 +15,26 @@ module CoreLint ( import CoreSyn import CoreFVs ( idFreeVars ) import CoreUtils ( findDefault, exprOkForSpeculation, coreBindsSize, mkPiType ) - +import Unify ( coreRefineTys ) import Bag import Literal ( literalType ) -import DataCon ( dataConRepType ) +import DataCon ( dataConRepType, isVanillaDataCon, dataConTyCon ) import Var ( Var, Id, TyVar, idType, tyVarKind, isTyVar, isId, mustHaveLocalBinding ) import VarSet -import Subst ( substTyWith ) import Name ( getSrcLoc ) import PprCore import ErrUtils ( dumpIfSet_core, ghcExit, Message, showPass, mkLocMessage, debugTraceMsg ) import SrcLoc ( SrcLoc, noSrcLoc, mkSrcSpan ) import Type ( Type, tyVarsOfType, eqType, - splitFunTy_maybe, mkTyVarTy, - splitForAllTy_maybe, splitTyConApp_maybe, splitTyConApp, + splitFunTy_maybe, + splitForAllTy_maybe, splitTyConApp_maybe, isUnLiftedType, typeKind, - isUnboxedTupleType, - isSubKind - ) -import TyCon ( isPrimTyCon ) + isUnboxedTupleType, isSubKind, + substTyWith, emptyTvSubst, extendTvInScope, + TvSubst, TvSubstEnv, setTvSubstEnv, substTy, + extendTvSubst, isInScope ) +import TyCon ( isPrimTyCon, TyCon ) import BasicTypes ( RecFlag(..), isNonRec ) import CmdLineOpts import Outputable @@ -45,7 +45,6 @@ import Util ( notNull ) import Maybe -infixr 9 `thenL`, `seqL` \end{code} %************************************************************************ @@ -124,10 +123,9 @@ lintCoreBindings dflags whoDunnit binds -- This is because transformation rules can bring something -- into use 'unexpectedly' lint_binds binds = addInScopeVars (bindersOfBinds binds) $ - mapL lint_bind binds + mapM lint_bind binds - lint_bind (Rec prs) = mapL (lintSingleBinding Recursive) prs `seqL` - returnL () + lint_bind (Rec prs) = mapM_ (lintSingleBinding Recursive) prs lint_bind (NonRec bndr rhs) = lintSingleBinding NonRecursive (bndr,rhs) display bad_news @@ -171,22 +169,17 @@ Check a core binding, returning the list of variables bound. \begin{code} lintSingleBinding rec_flag (binder,rhs) = addLoc (RhsOf binder) $ - - -- Check the rhs - lintCoreExpr rhs `thenL` \ ty -> - - -- Check match to RHS type - lintBinder binder `seqL` - checkTys binder_ty ty (mkRhsMsg binder ty) `seqL` - - -- Check (not isUnLiftedType) (also checks for bogus unboxed tuples) - checkL (not (isUnLiftedType binder_ty) + -- Check the rhs + do { ty <- lintCoreExpr rhs + ; lintBinder binder -- Check match to RHS type + ; binder_ty <- applySubst binder_ty + ; checkTys binder_ty ty (mkRhsMsg binder ty) + -- Check (not isUnLiftedType) (also checks for bogus unboxed tuples) + ; checkL (not (isUnLiftedType binder_ty) || (isNonRec rec_flag && exprOkForSpeculation rhs)) - (mkRhsPrimMsg binder rhs) `seqL` - + (mkRhsPrimMsg binder rhs) -- Check whether binder's specialisations contain any out-of-scope variables - mapL (checkBndrIdInScope binder) bndr_vars `seqL` - returnL () + ; mapM_ (checkBndrIdInScope binder) bndr_vars } -- We should check the unfolding, if any, but this is tricky because -- the unfolding is a SimplifiableCoreExpr. Give up for now. @@ -202,76 +195,112 @@ lintSingleBinding rec_flag (binder,rhs) %************************************************************************ \begin{code} + lintCoreExpr :: CoreExpr -> LintM Type +-- The returned type has the substitution from the monad +-- already applied to it: +-- lintCoreExpr e subst = exprTpye (subst e) + +lintCoreExpr (Var var) + = do { checkIdInScope var + ; applySubst (idType var) } -lintCoreExpr (Var var) = checkIdInScope var `seqL` returnL (idType var) -lintCoreExpr (Lit lit) = returnL (literalType lit) +lintCoreExpr (Lit lit) + = return (literalType lit) lintCoreExpr (Note (Coerce to_ty from_ty) expr) - = lintCoreExpr expr `thenL` \ expr_ty -> - lintTy to_ty `seqL` - lintTy from_ty `seqL` - checkTys from_ty expr_ty (mkCoerceErr from_ty expr_ty) `seqL` - returnL to_ty + = do { expr_ty <- lintCoreExpr expr + ; to_ty <- lintTy to_ty + ; from_ty <- lintTy from_ty + ; checkTys from_ty expr_ty (mkCoerceErr from_ty expr_ty) + ; return to_ty } lintCoreExpr (Note other_note expr) = lintCoreExpr expr lintCoreExpr (Let (NonRec bndr rhs) body) - = lintSingleBinding NonRecursive (bndr,rhs) `seqL` - addLoc (BodyOfLetRec [bndr]) - (addInScopeVars [bndr] (lintCoreExpr body)) + = do { lintSingleBinding NonRecursive (bndr,rhs) + ; addLoc (BodyOfLetRec [bndr]) + (addInScopeVars [bndr] (lintCoreExpr body)) } -lintCoreExpr (Let (Rec pairs) body) +lintCoreExpr (Let (Rec pairs) body) = addInScopeVars bndrs $ - mapL (lintSingleBinding Recursive) pairs `seqL` - addLoc (BodyOfLetRec bndrs) (lintCoreExpr body) + do { mapM (lintSingleBinding Recursive) pairs + ; addLoc (BodyOfLetRec bndrs) (lintCoreExpr body) } where bndrs = map fst pairs +lintCoreExpr (App fun (Type ty)) +-- This is like 'let' for types +-- It's needed when dealing with desugarer output for GADTs. Consider +-- data T = forall a. T a (a->Int) Bool +-- f :: T -> ... -> +-- f (T x f True) = <e1> +-- f (T y g False) = <e2> +-- After desugaring we get +-- f t b = case t of +-- T a (x::a) (f::a->Int) (b:Bool) -> +-- case b of +-- True -> <e1> +-- False -> (/\b. let y=x; g=f in <e2>) a +-- And for a reason I now forget, the ...<e2>... can mention a; so +-- we want Lint to know that b=a. Ugh. +-- +-- I tried quite hard to make the necessity for this go away, by changing the +-- desugarer, but the fundamental problem is this: +-- +-- T a (x::a) (y::Int) -> let fail::a = ... +-- in (/\b. ...(case ... of +-- True -> x::b +-- False -> fail) +-- ) a +-- Now the inner case look as though it has incompatible branches. + = go fun [ty] + where + go (App fun (Type ty)) tys + = do { go fun (ty:tys) } + go (Lam tv body) (ty:tys) + = do { checkL (isTyVar tv) (mkKindErrMsg tv ty) -- Not quite accurate + ; ty' <- lintTy ty; + ; checkKinds tv ty' + -- Now extend the substitution so we + -- take advantage of it in the body + ; addInScopeVars [tv] $ + extendSubstL tv ty' $ + go body tys } + go fun tys + = do { fun_ty <- lintCoreExpr fun + ; lintCoreArgs fun_ty (map Type tys) } + lintCoreExpr e@(App fun arg) - = lintCoreExpr fun `thenL` \ ty -> - addLoc (AnExpr e) $ - lintCoreArg ty arg + = do { ty <- lintCoreExpr fun + ; addLoc (AnExpr e) $ + lintCoreArg ty arg } lintCoreExpr (Lam var expr) - = addLoc (LambdaBodyOf var) $ - (if isId var then - checkL (not (isUnboxedTupleType (idType var))) (mkUnboxedTupleMsg var) - else - returnL ()) - `seqL` - (addInScopeVars [var] $ - lintCoreExpr expr `thenL` \ ty -> - - returnL (mkPiType var ty)) - -lintCoreExpr e@(Case scrut var alts) - = -- Check the scrutinee - lintCoreExpr scrut `thenL` \ scrut_ty -> - - -- Check the binder - lintBinder var `seqL` - - -- If this is an unboxed tuple case, then the binder must be dead - {- - checkL (if isUnboxedTupleType (idType var) - then isDeadBinder var - else True) (mkUnboxedTupleMsg var) `seqL` - -} - - checkTys (idType var) scrut_ty (mkScrutMsg var scrut_ty) `seqL` - - addInScopeVars [var] ( - - -- Check the alternatives - checkCaseAlts e scrut_ty alts `seqL` - - mapL (lintCoreAlt scrut_ty) alts `thenL` \ (alt_ty : alt_tys) -> - mapL (check alt_ty) alt_tys `seqL` - returnL alt_ty) - where - check alt_ty1 alt_ty2 = checkTys alt_ty1 alt_ty2 (mkCaseAltMsg e) + = addLoc (LambdaBodyOf var) $ + do { lintBinder var + ; ty <- addInScopeVars [var] $ + lintCoreExpr expr + ; applySubst (mkPiType var ty) } + -- The applySubst is needed to apply the subst to var + +lintCoreExpr e@(Case scrut var alt_ty alts) = + -- Check the scrutinee + do { scrut_ty <- lintCoreExpr scrut + ; alt_ty <- lintTy alt_ty + ; var_ty <- lintTy (idType var) + -- Don't use lintId on var, because unboxed tuple is legitimate + + ; checkTys var_ty scrut_ty (mkScrutMsg var scrut_ty) + + -- If the binder is an unboxed tuple type, don't put it in scope + ; let vars = if (isUnboxedTupleType (idType var)) then [] else [var] + ; addInScopeVars vars $ + do { -- Check the alternatives + checkCaseAlts e scrut_ty alts + ; mapM (lintCoreAlt scrut_ty alt_ty) alts + ; return alt_ty } } lintCoreExpr e@(Type ty) = addErrL (mkStrangeTyMsg e) @@ -288,66 +317,59 @@ subtype of the required type, as one would expect. \begin{code} lintCoreArgs :: Type -> [CoreArg] -> LintM Type -lintCoreArgs = lintCoreArgs0 checkTys - -lintCoreArg :: Type -> CoreArg -> LintM Type -lintCoreArg = lintCoreArg0 checkTys +lintCoreArg :: Type -> CoreArg -> LintM Type +-- First argument has already had substitution applied to it \end{code} -The primitive version of these functions takes a check argument, -allowing a different comparison. - \begin{code} -lintCoreArgs0 check_tys ty [] = returnL ty -lintCoreArgs0 check_tys ty (a : args) - = lintCoreArg0 check_tys ty a `thenL` \ res -> - lintCoreArgs0 check_tys res args - -lintCoreArg0 check_tys ty a@(Type arg_ty) - = lintTy arg_ty `seqL` - lintTyApp ty arg_ty - -lintCoreArg0 check_tys fun_ty arg - = -- Make sure function type matches argument - lintCoreExpr arg `thenL` \ arg_ty -> - let - err = mkAppMsg fun_ty arg_ty - in - case splitFunTy_maybe fun_ty of - Just (arg,res) -> check_tys arg arg_ty err `seqL` - returnL res - _ -> addErrL err +lintCoreArgs ty [] = return ty +lintCoreArgs ty (a : args) = + do { res <- lintCoreArg ty a + ; lintCoreArgs res args } + +lintCoreArg ty a@(Type arg_ty) = + do { arg_ty <- lintTy arg_ty + ; lintTyApp ty arg_ty } + +lintCoreArg fun_ty arg = + -- Make sure function type matches argument + do { arg_ty <- lintCoreExpr arg + ; let err = mkAppMsg fun_ty arg_ty + ; case splitFunTy_maybe fun_ty of + Just (arg,res) -> + do { checkTys arg arg_ty err + ; return res } + _ -> addErrL err } \end{code} \begin{code} +-- Both args have had substitution applied lintTyApp ty arg_ty = case splitForAllTy_maybe ty of Nothing -> addErrL (mkTyAppMsg ty arg_ty) - Just (tyvar,body) -> - if not (isTyVar tyvar) then addErrL (mkTyAppMsg ty arg_ty) else - let - tyvar_kind = tyVarKind tyvar - argty_kind = typeKind arg_ty - in - if argty_kind `isSubKind` tyvar_kind - -- Arg type might be boxed for a function with an uncommitted - -- tyvar; notably this is used so that we can give - -- error :: forall a:*. String -> a - -- and then apply it to both boxed and unboxed types. - then - returnL (substTyWith [tyvar] [arg_ty] body) - else - addErrL (mkKindErrMsg tyvar arg_ty) - -lintTyApps fun_ty [] - = returnL fun_ty - -lintTyApps fun_ty (arg_ty : arg_tys) - = lintTyApp fun_ty arg_ty `thenL` \ fun_ty' -> - lintTyApps fun_ty' arg_tys -\end{code} + Just (tyvar,body) + -> do { checkL (isTyVar tyvar) (mkTyAppMsg ty arg_ty) + ; checkKinds tyvar arg_ty + ; return (substTyWith [tyvar] [arg_ty] body) } + +lintTyApps fun_ty [] = return fun_ty +lintTyApps fun_ty (arg_ty : arg_tys) = + do { fun_ty' <- lintTyApp fun_ty arg_ty + ; lintTyApps fun_ty' arg_tys } + +checkKinds tyvar arg_ty + -- Arg type might be boxed for a function with an uncommitted + -- tyvar; notably this is used so that we can give + -- error :: forall a:*. String -> a + -- and then apply it to both boxed and unboxed types. + = checkL (argty_kind `isSubKind` tyvar_kind) + (mkKindErrMsg tyvar arg_ty) + where + tyvar_kind = tyVarKind tyvar + argty_kind = typeKind arg_ty +\end{code} %************************************************************************ @@ -368,10 +390,10 @@ checkCaseAlts :: CoreExpr -> Type -> [CoreAlt] -> LintM () checkCaseAlts e ty [] = addErrL (mkNullAltsMsg e) -checkCaseAlts e ty alts - = checkL (all non_deflt con_alts) (mkNonDefltMsg e) `seqL` - checkL (isJust maybe_deflt || not is_infinite_ty) - (nonExhaustiveAltsMsg e) +checkCaseAlts e ty alts = + do { checkL (all non_deflt con_alts) (mkNonDefltMsg e) + ; checkL (isJust maybe_deflt || not is_infinite_ty) + (nonExhaustiveAltsMsg e) } where (con_alts, maybe_deflt) = findDefault alts @@ -384,48 +406,67 @@ checkCaseAlts e ty alts \end{code} \begin{code} +checkAltExpr :: CoreExpr -> Type -> LintM () +checkAltExpr expr ty + = do { actual_ty <- lintCoreExpr expr + ; ty' <- applySubst ty + ; checkTys actual_ty ty' (mkCaseAltMsg expr actual_ty ty') } + lintCoreAlt :: Type -- Type of scrutinee + -> Type -- Type of the alternative -> CoreAlt - -> LintM Type -- Type of alternatives + -> LintM () -lintCoreAlt scrut_ty alt@(DEFAULT, args, rhs) - = checkL (null args) (mkDefaultArgsMsg args) `seqL` - lintCoreExpr rhs +lintCoreAlt scrut_ty alt_ty alt@(DEFAULT, args, rhs) = + do { checkL (null args) (mkDefaultArgsMsg args) + ; checkAltExpr rhs alt_ty } -lintCoreAlt scrut_ty alt@(LitAlt lit, args, rhs) - = checkL (null args) (mkDefaultArgsMsg args) `seqL` - checkTys lit_ty scrut_ty - (mkBadPatMsg lit_ty scrut_ty) `seqL` - lintCoreExpr rhs +lintCoreAlt scrut_ty alt_ty alt@(LitAlt lit, args, rhs) = + do { checkL (null args) (mkDefaultArgsMsg args) + ; checkTys lit_ty scrut_ty + (mkBadPatMsg lit_ty scrut_ty) + ; checkAltExpr rhs alt_ty } where lit_ty = literalType lit -lintCoreAlt scrut_ty alt@(DataAlt con, args, rhs) - = addLoc (CaseAlt alt) ( - - mapL (\arg -> checkL (not (isId arg && isUnboxedTupleType (idType arg))) - (mkUnboxedTupleMsg arg)) args `seqL` - - addInScopeVars args ( - - -- Check the pattern - -- Scrutinee type must be a tycon applicn; checked by caller - -- This code is remarkably compact considering what it does! - -- NB: args must be in scope here so that the lintCoreArgs line works. - -- NB: relies on existential type args coming *after* ordinary type args - case splitTyConApp scrut_ty of { (tycon, tycon_arg_tys) -> - lintTyApps (dataConRepType con) tycon_arg_tys `thenL` \ con_type -> - lintCoreArgs con_type (map mk_arg args) `thenL` \ con_result_ty -> - checkTys con_result_ty scrut_ty (mkBadPatMsg con_result_ty scrut_ty) - } `seqL` - - -- Check the RHS - lintCoreExpr rhs - )) - where - mk_arg b | isTyVar b = Type (mkTyVarTy b) - | isId b = Var b - | otherwise = pprPanic "lintCoreAlt:mk_arg " (ppr b) +lintCoreAlt scrut_ty alt_ty alt@(DataAlt con, args, rhs) + | isVanillaDataCon con + = addLoc (CaseAlt alt) $ + addInScopeVars args $ + do { mapM lintBinder args + -- FIX! Add check that all args are Ids. + -- Check the pattern + -- Scrutinee type must be a tycon applicn; checked by caller + -- This code is remarkably compact considering what it does! + -- NB: args must be in scope here so that the lintCoreArgs line works. + -- NB: relies on existential type args coming *after* ordinary type args + + ; case splitTyConApp_maybe scrut_ty of { + Just (tycon, tycon_arg_tys) -> + do { con_type <- lintTyApps (dataConRepType con) tycon_arg_tys + -- Can just map Var as we know that this is a vanilla datacon + ; con_result_ty <- lintCoreArgs con_type (map Var args) + ; checkTys con_result_ty scrut_ty (mkBadPatMsg con_result_ty scrut_ty) + -- Check the RHS + ; checkAltExpr rhs alt_ty } ; + Nothing -> addErrL (mkBadAltMsg scrut_ty alt) + } } + + | otherwise + = addLoc (CaseAlt alt) $ + addInScopeVars args $ -- Put the args in scope before lintBinder, because + -- the Ids mention the type variables + do { mapM lintBinder args + ; case splitTyConApp_maybe scrut_ty of { + Nothing -> addErrL (mkBadAltMsg scrut_ty alt) ; + Just (tycon, tycon_args_tys) -> + do { checkL (tycon == dataConTyCon con) (mkIncTyconMsg tycon alt) + ; pat_res_ty <- lintCoreArgs (dataConRepType con) (map varToCoreExpr args) + ; subst <- getTvSubst + ; case coreRefineTys args subst pat_res_ty scrut_ty of + Just senv -> updateTvSubstEnv senv (checkAltExpr rhs alt_ty) + Nothing -> return () -- Alternative is dead code + } } } \end{code} %************************************************************************ @@ -436,14 +477,24 @@ lintCoreAlt scrut_ty alt@(DataAlt con, args, rhs) \begin{code} lintBinder :: Var -> LintM () -lintBinder v = nopL --- ToDo: lint its type --- ToDo: lint its rules +lintBinder var | isId var = lintId var >> return () + | otherwise = return () -lintTy :: Type -> LintM () -lintTy ty = mapL checkIdInScope (varSetElems (tyVarsOfType ty)) `seqL` - returnL () - -- ToDo: check the kind structure of the type +lintId :: Var -> LintM Type +-- ToDo: lint its rules +lintId id + = do { checkL (not (isUnboxedTupleType (idType id))) + (mkUnboxedTupleMsg id) + -- No variable can be bound to an unboxed tuple. + ; lintTy (idType id) } + +lintTy :: Type -> LintM Type +-- Check the type, and apply the substitution to it +-- ToDo: check the kind structure of the type +lintTy ty + = do { ty' <- applySubst ty + ; mapM_ checkIdInScope (varSetElems (tyVarsOfType ty')) + ; return ty' } \end{code} @@ -454,10 +505,23 @@ lintTy ty = mapL checkIdInScope (varSetElems (tyVarsOfType ty)) `seqL` %************************************************************************ \begin{code} -type LintM a = [LintLocInfo] -- Locations - -> IdSet -- Local vars in scope - -> Bag Message -- Error messages so far - -> (Maybe a, Bag Message) -- Result and error messages (if any) +newtype LintM a = + LintM { unLintM :: + [LintLocInfo] -> -- Locations + TvSubst -> -- Current type substitution; we also use this + -- to keep track of all the variables in scope, + -- both Ids and TyVars + Bag Message -> -- Error messages so far + (Maybe a, Bag Message) } -- Result and error messages (if any) + +instance Monad LintM where + return x = LintM (\ loc subst errs -> (Just x, errs)) + fail err = LintM (\ loc subst errs -> (Nothing, addErr subst errs (text err) loc)) + m >>= k = LintM (\ loc subst errs -> + let (res, errs') = unLintM m loc subst errs in + case res of + Just r -> unLintM (k r) loc subst errs' + Nothing -> (Nothing, errs')) data LintLocInfo = RhsOf Id -- The variable bound @@ -468,65 +532,58 @@ data LintLocInfo | ImportedUnfolding SrcLoc -- Some imported unfolding (ToDo: say which) \end{code} + \begin{code} initL :: LintM a -> Maybe Message {- errors -} initL m - = case m [] emptyVarSet emptyBag of + = case unLintM m [] emptyTvSubst emptyBag of (_, errs) | isEmptyBag errs -> Nothing | otherwise -> Just (vcat (punctuate (text "") (bagToList errs))) - -returnL :: a -> LintM a -returnL r loc scope errs = (Just r, errs) - -nopL :: LintM a -nopL loc scope errs = (Nothing, errs) - -thenL :: LintM a -> (a -> LintM b) -> LintM b -thenL m k loc scope errs - = case m loc scope errs of - (Just r, errs') -> k r loc scope errs' - (Nothing, errs') -> (Nothing, errs') - -seqL :: LintM a -> LintM b -> LintM b -seqL m k loc scope errs - = case m loc scope errs of - (_, errs') -> k loc scope errs' - -mapL :: (a -> LintM b) -> [a] -> LintM [b] -mapL f [] = returnL [] -mapL f (x:xs) - = f x `thenL` \ r -> - mapL f xs `thenL` \ rs -> - returnL (r:rs) \end{code} \begin{code} checkL :: Bool -> Message -> LintM () -checkL True msg = nopL +checkL True msg = return () checkL False msg = addErrL msg addErrL :: Message -> LintM a -addErrL msg loc scope errs = (Nothing, addErr errs msg loc) +addErrL msg = LintM (\ loc subst errs -> (Nothing, addErr subst errs msg loc)) -addErr :: Bag Message -> Message -> [LintLocInfo] -> Bag Message -addErr errs_so_far msg locs +addErr :: TvSubst -> Bag Message -> Message -> [LintLocInfo] -> Bag Message +addErr subst errs_so_far msg locs = ASSERT( notNull locs ) errs_so_far `snocBag` mk_msg msg where (loc, cxt1) = dumpLoc (head locs) cxts = [snd (dumpLoc loc) | loc <- locs] - context | opt_PprStyle_Debug = vcat (reverse cxts) $$ cxt1 + context | opt_PprStyle_Debug = vcat (reverse cxts) $$ cxt1 $$ + ptext SLIT("Substitution:") <+> ppr subst | otherwise = cxt1 mk_msg msg = mkLocMessage (mkSrcSpan loc loc) (context $$ msg) addLoc :: LintLocInfo -> LintM a -> LintM a -addLoc extra_loc m loc scope errs - = m (extra_loc:loc) scope errs +addLoc extra_loc m = + LintM (\ loc subst errs -> unLintM m (extra_loc:loc) subst errs) addInScopeVars :: [Var] -> LintM a -> LintM a -addInScopeVars ids m loc scope errs - = m loc (extendVarSetList scope ids) errs +addInScopeVars vars m = + LintM (\ loc subst errs -> unLintM m loc (extendTvInScope subst vars) errs) + +-- gaw 2004 +updateTvSubstEnv :: TvSubstEnv -> LintM a -> LintM a +updateTvSubstEnv substenv m = + LintM (\ loc subst errs -> unLintM m loc (setTvSubstEnv subst substenv) errs) + +getTvSubst :: LintM TvSubst +getTvSubst = LintM (\ loc subst errs -> (Just subst, errs)) + +applySubst :: Type -> LintM Type +applySubst ty = do { subst <- getTvSubst; return (substTy subst ty) } + +extendSubstL :: TyVar -> Type -> LintM a -> LintM a +extendSubstL tv ty m + = LintM (\ loc subst errs -> unLintM m loc (extendTvSubst subst tv ty) errs) \end{code} \begin{code} @@ -542,21 +599,18 @@ checkBndrIdInScope binder id ppr binder checkInScope :: SDoc -> Var -> LintM () -checkInScope loc_msg var loc scope errs - | mustHaveLocalBinding var && not (var `elemVarSet` scope) - = (Nothing, addErr errs (hsep [ppr var, loc_msg]) loc) - | otherwise - = nopL loc scope errs +checkInScope loc_msg var = + do { subst <- getTvSubst + ; checkL (not (mustHaveLocalBinding var) || (var `isInScope` subst)) + (hsep [ppr var, loc_msg]) } checkTys :: Type -> Type -> Message -> LintM () -- check ty2 is subtype of ty1 (ie, has same structure but usage -- annotations need only be consistent, not equal) -checkTys ty1 ty2 msg - | ty1 `eqType` ty2 = nopL - | otherwise = addErrL msg +-- Assumes ty1,ty2 are have alrady had the substitution applied +checkTys ty1 ty2 msg = checkL (ty1 `eqType` ty2) msg \end{code} - %************************************************************************ %* * \subsection{Error messages} @@ -580,7 +634,7 @@ dumpLoc (AnExpr e) = (noSrcLoc, text "In the expression:" <+> ppr e) dumpLoc (CaseAlt (con, args, rhs)) - = (noSrcLoc, text "In a case pattern:" <+> parens (ppr con <+> ppr args)) + = (noSrcLoc, text "In a case alternative:" <+> parens (ppr con <+> ppr args)) dumpLoc (ImportedUnfolding locn) = (locn, brackets (ptext SLIT("in an imported unfolding"))) @@ -607,10 +661,10 @@ mkDefaultArgsMsg args = hang (text "DEFAULT case with binders") 4 (ppr args) -mkCaseAltMsg :: CoreExpr -> Message -mkCaseAltMsg e - = hang (text "Type of case alternatives not the same:") - 4 (ppr e) +mkCaseAltMsg :: CoreExpr -> Type -> Type -> Message +mkCaseAltMsg e ty1 ty2 + = hang (text "Type of case alternatives not the same as the annotation on case:") + 4 (vcat [ppr ty1, ppr ty2, ppr e]) mkScrutMsg :: Id -> Type -> Message mkScrutMsg var scrut_ty @@ -634,6 +688,19 @@ mkBadPatMsg con_result_ty scrut_ty text "Scrutinee type:" <+> ppr scrut_ty ] +mkBadAltMsg :: Type -> CoreAlt -> Message +mkBadAltMsg scrut_ty alt + = vcat [ text "Data alternative when scrutinee is not a tycon application", + text "Scrutinee type:" <+> ppr scrut_ty, + text "Alternative:" <+> pprCoreAlt alt ] + +mkIncTyconMsg :: TyCon -> CoreAlt -> Message +mkIncTyconMsg tycon1 alt@(DataAlt con,_,_) + = vcat [ text "Incompatible tycon applications in alternative", + text "Scrutinee tycon:" <+> ppr tycon1, + text "Alternative tycon:" <+> ppr (dataConTyCon con), + text "Alternative:" <+> pprCoreAlt alt ] + ------------------------------------------------------ -- Other error messages diff --git a/ghc/compiler/coreSyn/CorePrep.lhs b/ghc/compiler/coreSyn/CorePrep.lhs index 1602a07b86..925a51f6ac 100644 --- a/ghc/compiler/coreSyn/CorePrep.lhs +++ b/ghc/compiler/coreSyn/CorePrep.lhs @@ -407,12 +407,14 @@ corePrepExprFloat env expr@(Lam _ _) where (bndrs,body) = collectBinders expr -corePrepExprFloat env (Case scrut bndr alts) +-- gaw 2004 +corePrepExprFloat env (Case scrut bndr ty alts) = corePrepExprFloat env scrut `thenUs` \ (floats1, scrut1) -> deLamFloat scrut1 `thenUs` \ (floats2, scrut2) -> cloneBndr env bndr `thenUs` \ (env', bndr') -> mapUs (sat_alt env') alts `thenUs` \ alts' -> - returnUs (floats1 `appendFloats` floats2 , Case scrut2 bndr' alts') +-- gaw 2004 + returnUs (floats1 `appendFloats` floats2 , Case scrut2 bndr' ty alts') where sat_alt env (con, bs, rhs) = cloneBndrs env bs `thenUs` \ (env', bs') -> @@ -585,7 +587,8 @@ mkBinds (Floats _ binds) body | otherwise = deLam body `thenUs` \ body' -> returnUs (foldrOL mk_bind body' binds) where - mk_bind (FloatCase bndr rhs _) body = Case rhs bndr [(DEFAULT, [], body)] +-- gaw 2004 + mk_bind (FloatCase bndr rhs _) body = Case rhs bndr (exprType body) [(DEFAULT, [], body)] mk_bind (FloatLet bind) body = Let bind body etaExpandRhs bndr rhs diff --git a/ghc/compiler/coreSyn/CoreSyn.lhs b/ghc/compiler/coreSyn/CoreSyn.lhs index a074499fd3..69c49ddfd7 100644 --- a/ghc/compiler/coreSyn/CoreSyn.lhs +++ b/ghc/compiler/coreSyn/CoreSyn.lhs @@ -78,7 +78,8 @@ data Expr b -- "b" for the type of binders, | App (Expr b) (Arg b) | Lam b (Expr b) | Let (Bind b) (Expr b) - | Case (Expr b) b [Alt b] -- Binder gets bound to value of scrutinee + -- gaw 2004, added Type field + | Case (Expr b) b Type [Alt b] -- Binder gets bound to value of scrutinee -- Invariant: The list of alternatives is ALWAYS EXHAUSTIVE, -- meaning that it covers all cases that can occur -- See the example below @@ -554,14 +555,15 @@ valArgCount (other : args) = 1 + valArgCount args \begin{code} seqExpr :: CoreExpr -> () -seqExpr (Var v) = v `seq` () -seqExpr (Lit lit) = lit `seq` () -seqExpr (App f a) = seqExpr f `seq` seqExpr a -seqExpr (Lam b e) = seqBndr b `seq` seqExpr e -seqExpr (Let b e) = seqBind b `seq` seqExpr e -seqExpr (Case e b as) = seqExpr e `seq` seqBndr b `seq` seqAlts as -seqExpr (Note n e) = seqNote n `seq` seqExpr e -seqExpr (Type t) = seqType t +seqExpr (Var v) = v `seq` () +seqExpr (Lit lit) = lit `seq` () +seqExpr (App f a) = seqExpr f `seq` seqExpr a +seqExpr (Lam b e) = seqBndr b `seq` seqExpr e +seqExpr (Let b e) = seqBind b `seq` seqExpr e +-- gaw 2004 +seqExpr (Case e b t as) = seqExpr e `seq` seqBndr b `seq` seqType t `seq` seqAlts as +seqExpr (Note n e) = seqNote n `seq` seqExpr e +seqExpr (Type t) = seqType t seqExprs [] = () seqExprs (e:es) = seqExpr e `seq` seqExprs es @@ -608,7 +610,8 @@ data AnnExpr' bndr annot | AnnLit Literal | AnnLam bndr (AnnExpr bndr annot) | AnnApp (AnnExpr bndr annot) (AnnExpr bndr annot) - | AnnCase (AnnExpr bndr annot) bndr [AnnAlt bndr annot] +-- gaw 2004 + | AnnCase (AnnExpr bndr annot) bndr Type [AnnAlt bndr annot] | AnnLet (AnnBind bndr annot) (AnnExpr bndr annot) | AnnNote Note (AnnExpr bndr annot) | AnnType Type @@ -637,8 +640,9 @@ deAnnotate' (AnnLet bind body) deAnnBind (AnnNonRec var rhs) = NonRec var (deAnnotate rhs) deAnnBind (AnnRec pairs) = Rec [(v,deAnnotate rhs) | (v,rhs) <- pairs] -deAnnotate' (AnnCase scrut v alts) - = Case (deAnnotate scrut) v (map deAnnAlt alts) +-- gaw 2004 +deAnnotate' (AnnCase scrut v t alts) + = Case (deAnnotate scrut) v t (map deAnnAlt alts) deAnnAlt :: AnnAlt bndr annot -> Alt bndr deAnnAlt (con,args,rhs) = (con,args,deAnnotate rhs) diff --git a/ghc/compiler/coreSyn/CoreTidy.lhs b/ghc/compiler/coreSyn/CoreTidy.lhs index 093067e87a..9c03072e61 100644 --- a/ghc/compiler/coreSyn/CoreTidy.lhs +++ b/ghc/compiler/coreSyn/CoreTidy.lhs @@ -71,9 +71,11 @@ tidyExpr env (Let b e) = tidyBind env b =: \ (env', b') -> Let b' (tidyExpr env' e) -tidyExpr env (Case e b alts) +-- gaw 2004 +tidyExpr env (Case e b ty alts) = tidyBndr env b =: \ (env', b) -> - Case (tidyExpr env e) b (map (tidyAlt env') alts) +-- gaw 2004 + Case (tidyExpr env e) b (tidyType env ty) (map (tidyAlt env') alts) tidyExpr env (Lam b e) = tidyBndr env b =: \ (env', b) -> diff --git a/ghc/compiler/coreSyn/CoreUnfold.lhs b/ghc/compiler/coreSyn/CoreUnfold.lhs index baf76c7225..d3c1679e09 100644 --- a/ghc/compiler/coreSyn/CoreUnfold.lhs +++ b/ghc/compiler/coreSyn/CoreUnfold.lhs @@ -218,7 +218,8 @@ sizeExpr bOMB_OUT_SIZE top_args expr where rhs_size = foldr (addSize . size_up . snd) sizeZero pairs - size_up (Case (Var v) _ alts) +-- gaw 2004 + size_up (Case (Var v) _ _ alts) | v `elem` top_args -- We are scrutinising an argument variable = {- I'm nuking this special case; BUT see the comment with case alternatives. @@ -266,9 +267,9 @@ sizeExpr bOMB_OUT_SIZE top_args expr -- The 1+ is a little discount for reduced allocation in the caller alts_size tot_size _ = tot_size - - size_up (Case e _ alts) = nukeScrutDiscount (size_up e) `addSize` - foldr (addSize . size_up_alt) sizeZero alts +-- gaw 2004 + size_up (Case e _ _ alts) = nukeScrutDiscount (size_up e) `addSize` + foldr (addSize . size_up_alt) sizeZero alts -- We don't charge for the case itself -- It's a strict thing, and the price of the call -- is paid by scrut. Also consider diff --git a/ghc/compiler/coreSyn/CoreUtils.lhs b/ghc/compiler/coreSyn/CoreUtils.lhs index 4c148cc1b8..440365d7d3 100644 --- a/ghc/compiler/coreSyn/CoreUtils.lhs +++ b/ghc/compiler/coreSyn/CoreUtils.lhs @@ -14,10 +14,10 @@ module CoreUtils ( findDefault, findAlt, -- Properties of expressions - exprType, + exprType, coreAltType, exprIsDupable, exprIsTrivial, exprIsCheap, exprIsValue,exprOkForSpeculation, exprIsBig, - exprIsConApp_maybe, + exprIsConApp_maybe, exprIsBottom, rhsIsStatic, -- Arity and eta expansion @@ -47,7 +47,7 @@ import Name ( hashName, isDllName ) import Literal ( hashLiteral, literalType, litIsDupable, litIsTrivial, isZeroLit, Literal( MachLabel ) ) import DataCon ( DataCon, dataConRepArity, dataConArgTys, - isExistentialDataCon, dataConTyCon ) + isVanillaDataCon, dataConTyCon ) import PrimOp ( PrimOp(..), primOpOkForSpeculation, primOpIsCheap ) import Id ( Id, idType, globalIdDetails, idNewStrictness, mkWildId, idArity, idName, idUnfolding, idInfo, @@ -64,6 +64,7 @@ import Type ( Type, mkFunTy, mkForAllTy, splitFunTy_maybe, funResultTy, applyTy ) import TyCon ( tyConArity ) +-- gaw 2004 import TysWiredIn ( boolTy, trueDataCon, falseDataCon ) import CostCentre ( CostCentre ) import BasicTypes ( Arity ) @@ -86,7 +87,8 @@ exprType :: CoreExpr -> Type exprType (Var var) = idType var exprType (Lit lit) = literalType lit exprType (Let _ body) = exprType body -exprType (Case _ _ alts) = coreAltsType alts +-- gaw 2004 +exprType (Case _ _ ty alts) = ty exprType (Note (Coerce ty _) e) = ty -- **! should take usage from e exprType (Note other_note e) = exprType e exprType (Lam binder expr) = mkPiType binder (exprType expr) @@ -96,8 +98,8 @@ exprType e@(App _ _) exprType other = pprTrace "exprType" (pprCoreExpr other) alphaTy -coreAltsType :: [CoreAlt] -> Type -coreAltsType ((_,_,rhs) : _) = exprType rhs +coreAltType :: CoreAlt -> Type +coreAltType (_,_,rhs) = exprType rhs \end{code} @mkPiType@ makes a (->) type or a forall type, depending on whether @@ -240,8 +242,10 @@ bindNonRec :: Id -> CoreExpr -> CoreExpr -> CoreExpr -- It's used by the desugarer to avoid building bindings -- that give Core Lint a heart attack. Actually the simplifier -- deals with them perfectly well. + bindNonRec bndr rhs body - | needsCaseBinding (idType bndr) rhs = Case rhs bndr [(DEFAULT,[],body)] +-- gaw 2004 + | needsCaseBinding (idType bndr) rhs = Case rhs bndr (exprType body) [(DEFAULT,[],body)] | otherwise = Let (NonRec bndr rhs) body needsCaseBinding ty rhs = isUnLiftedType ty && not (exprOkForSpeculation rhs) @@ -261,7 +265,9 @@ mkAltExpr (LitAlt lit) [] [] mkIfThenElse :: CoreExpr -> CoreExpr -> CoreExpr -> CoreExpr mkIfThenElse guard then_expr else_expr - = Case guard (mkWildId boolTy) +-- gaw 2004 +-- Not going to be refining, so okay to take the type of the "then" clause + = Case guard (mkWildId boolTy) (exprType then_expr) [ (DataAlt trueDataCon, [], then_expr), (DataAlt falseDataCon, [], else_expr) ] \end{code} @@ -399,13 +405,14 @@ because sharing will make sure it is only evaluated once. \begin{code} exprIsCheap :: CoreExpr -> Bool -exprIsCheap (Lit lit) = True -exprIsCheap (Type _) = True -exprIsCheap (Var _) = True -exprIsCheap (Note InlineMe e) = True -exprIsCheap (Note _ e) = exprIsCheap e -exprIsCheap (Lam x e) = isRuntimeVar x || exprIsCheap e -exprIsCheap (Case e _ alts) = exprIsCheap e && +exprIsCheap (Lit lit) = True +exprIsCheap (Type _) = True +exprIsCheap (Var _) = True +exprIsCheap (Note InlineMe e) = True +exprIsCheap (Note _ e) = exprIsCheap e +exprIsCheap (Lam x e) = isRuntimeVar x || exprIsCheap e +-- gaw 2004 +exprIsCheap (Case e _ _ alts) = exprIsCheap e && and [exprIsCheap rhs | (_,_,rhs) <- alts] -- Experimentally, treat (case x of ...) as cheap -- (and case __coerce x etc.) @@ -442,7 +449,7 @@ idAppIsCheap id n_val_args -- counts as WHNF | otherwise = case globalIdDetails id of DataConWorkId _ -> True - RecordSelId _ -> True -- I'm experimenting with making record selection + RecordSelId _ _ -> True -- I'm experimenting with making record selection ClassOpId _ -> True -- look cheap, so we will substitute it inside a -- lambda. Particularly for dictionary field selection @@ -534,13 +541,14 @@ exprIsBottom :: CoreExpr -> Bool -- True => definitely bottom exprIsBottom e = go 0 e where -- n is the number of args - go n (Note _ e) = go n e - go n (Let _ e) = go n e - go n (Case e _ _) = go 0 e -- Just check the scrut - go n (App e _) = go (n+1) e - go n (Var v) = idAppIsBottom v n - go n (Lit _) = False - go n (Lam _ _) = False + go n (Note _ e) = go n e + go n (Let _ e) = go n e +-- gaw 2004 + go n (Case e _ _ _) = go 0 e -- Just check the scrut + go n (App e _) = go (n+1) e + go n (Var v) = idAppIsBottom v n + go n (Lit _) = False + go n (Lam _ _) = False idAppIsBottom :: Id -> Int -> Bool idAppIsBottom id n_val_args = appIsBottom (idNewStrictness id) n_val_args @@ -627,9 +635,9 @@ exprIsConApp_maybe (Note (Coerce to_ty from_ty) expr) case splitTyConApp_maybe to_ty of { Nothing -> Nothing ; - Just (tc, tc_arg_tys) | tc /= dataConTyCon dc -> Nothing - | isExistentialDataCon dc -> Nothing - | otherwise -> + Just (tc, tc_arg_tys) | tc /= dataConTyCon dc -> Nothing + | not (isVanillaDataCon dc) -> Nothing + | otherwise -> -- Type constructor must match -- We knock out existentials to keep matters simple(r) let @@ -807,7 +815,8 @@ arityType (App f a) = case arityType f of -- ===> -- f x y = case x of { (a,b) -> e } -- The difference is observable using 'seq' -arityType (Case scrut _ alts) = case foldr1 andArityType [arityType rhs | (_,_,rhs) <- alts] of +-- gaw 2004 +arityType (Case scrut _ _ alts) = case foldr1 andArityType [arityType rhs | (_,_,rhs) <- alts] of xs@(AFun one_shot _) | one_shot -> xs xs | exprIsCheap scrut -> xs | otherwise -> ATop @@ -1038,8 +1047,10 @@ eqExpr e1 e2 where env' = extendVarEnvList env [(v1,v2) | ((v1,_),(v2,_)) <- zip ps1 ps2] eq_rhs (_,r1) (_,r2) = eq env' r1 r2 - eq env (Case e1 v1 a1) - (Case e2 v2 a2) = eq env e1 e2 && +-- gaw 2004 + eq env (Case e1 v1 t1 a1) + (Case e2 v2 t2 a2) = eq env e1 e2 && + t1 `eqType` t2 && equalLength a1 a2 && and (zipWith (eq_alt env') a1 a2) where @@ -1077,14 +1088,15 @@ coreBindsSize bs = foldr ((+) . bindSize) 0 bs exprSize :: CoreExpr -> Int -- A measure of the size of the expressions -- It also forces the expression pretty drastically as a side effect -exprSize (Var v) = v `seq` 1 -exprSize (Lit lit) = lit `seq` 1 -exprSize (App f a) = exprSize f + exprSize a -exprSize (Lam b e) = varSize b + exprSize e -exprSize (Let b e) = bindSize b + exprSize e -exprSize (Case e b as) = exprSize e + varSize b + foldr ((+) . altSize) 0 as -exprSize (Note n e) = noteSize n + exprSize e -exprSize (Type t) = seqType t `seq` 1 +exprSize (Var v) = v `seq` 1 +exprSize (Lit lit) = lit `seq` 1 +exprSize (App f a) = exprSize f + exprSize a +exprSize (Lam b e) = varSize b + exprSize e +exprSize (Let b e) = bindSize b + exprSize e +-- gaw 2004 +exprSize (Case e b t as) = seqType t `seq` exprSize e + varSize b + 1 + foldr ((+) . altSize) 0 as +exprSize (Note n e) = noteSize n + exprSize e +exprSize (Type t) = seqType t `seq` 1 noteSize (SCC cc) = cc `seq` 1 noteSize (Coerce t1 t2) = seqType t1 `seq` seqType t2 `seq` 1 @@ -1125,7 +1137,8 @@ hashExpr e | hash < 0 = 77 -- Just in case we hit -maxInt hash_expr (Note _ e) = hash_expr e hash_expr (Let (NonRec b r) e) = hashId b hash_expr (Let (Rec ((b,r):_)) e) = hashId b -hash_expr (Case _ b _) = hashId b +-- gaw 2004 +hash_expr (Case _ b _ _) = hashId b hash_expr (App f e) = hash_expr f * fast_hash_expr e hash_expr (Var v) = hashId v hash_expr (Lit lit) = hashLiteral lit diff --git a/ghc/compiler/coreSyn/ExternalCore.lhs b/ghc/compiler/coreSyn/ExternalCore.lhs index d7eb45579a..09a6e7f7da 100644 --- a/ghc/compiler/coreSyn/ExternalCore.lhs +++ b/ghc/compiler/coreSyn/ExternalCore.lhs @@ -15,6 +15,7 @@ data Tdef data Cdef = Constr Dcon [Tbind] [Ty] + | GadtConstr Dcon Ty data Vdefg = Rec [Vdef] @@ -30,7 +31,7 @@ data Exp | Appt Exp Ty | Lam Bind Exp | Let Vdefg Exp - | Case Exp Vbind [Alt] {- non-empty list -} + | Case Exp Vbind Ty [Alt] {- non-empty list -} | Coerce Ty Exp | Note String Exp | External String Ty diff --git a/ghc/compiler/coreSyn/MkExternalCore.lhs b/ghc/compiler/coreSyn/MkExternalCore.lhs index 6b21f1835f..03049fb75c 100644 --- a/ghc/compiler/coreSyn/MkExternalCore.lhs +++ b/ghc/compiler/coreSyn/MkExternalCore.lhs @@ -19,8 +19,8 @@ import Class import TypeRep import Type import PprExternalCore -- Instances -import DataCon ( DataCon, dataConExistentialTyVars, dataConRepArgTys, - dataConName, dataConWrapId_maybe ) +import DataCon ( DataCon, dataConTyVars, dataConRepArgTys, + dataConName, dataConTyCon, dataConWrapId_maybe ) import CoreSyn import Var import IdInfo @@ -112,7 +112,7 @@ make_cdef dcon = C.Constr dcon_name existentials tys where dcon_name = make_var_id (dataConName dcon) existentials = map make_tbind ex_tyvars - ex_tyvars = dataConExistentialTyVars dcon + ex_tyvars = drop (tyConArity (dataConTyCon dcon)) (dataConTyVars dcon) tys = map make_ty (dataConRepArgTys dcon) make_tbind :: TyVar -> C.Tbind @@ -144,7 +144,8 @@ make_exp (App e1 e2) = C.App (make_exp e1) (make_exp e2) make_exp (Lam v e) | isTyVar v = C.Lam (C.Tb (make_tbind v)) (make_exp e) make_exp (Lam v e) | otherwise = C.Lam (C.Vb (make_vbind v)) (make_exp e) make_exp (Let b e) = C.Let (make_vdef b) (make_exp e) -make_exp (Case e v alts) = C.Case (make_exp e) (make_vbind v) (map make_alt alts) +-- gaw 2004 +make_exp (Case e v ty alts) = C.Case (make_exp e) (make_vbind v) (make_ty ty) (map make_alt alts) make_exp (Note (SCC cc) e) = C.Note "SCC" (make_exp e) -- temporary make_exp (Note (Coerce t_to t_from) e) = C.Coerce (make_ty t_to) (make_exp e) make_exp (Note InlineCall e) = C.Note "InlineCall" (make_exp e) diff --git a/ghc/compiler/coreSyn/PprCore.lhs b/ghc/compiler/coreSyn/PprCore.lhs index f3969741a2..ec52bb692b 100644 --- a/ghc/compiler/coreSyn/PprCore.lhs +++ b/ghc/compiler/coreSyn/PprCore.lhs @@ -153,11 +153,12 @@ ppr_expr add_par expr@(App fun arg) other -> add_par (hang (pprParendExpr fun) 2 pp_args) } -ppr_expr add_par (Case expr var [(con,args,rhs)]) +-- gaw 2004 +ppr_expr add_par (Case expr var ty [(con,args,rhs)]) = add_par $ - sep [sep [ptext SLIT("case") <+> pprCoreExpr expr, + sep [sep [ptext SLIT("case") <+> parens (ppr ty) <+> pprCoreExpr expr, hsep [ptext SLIT("of"), - ppr_bndr var, + ppr_bndr var, char '{', ppr_case_pat con args ]], @@ -167,9 +168,10 @@ ppr_expr add_par (Case expr var [(con,args,rhs)]) where ppr_bndr = pprBndr CaseBind -ppr_expr add_par (Case expr var alts) +-- gaw 2004 +ppr_expr add_par (Case expr var ty alts) = add_par $ - sep [sep [ptext SLIT("case") <+> pprCoreExpr expr, + sep [sep [ptext SLIT("case") <+> parens (ppr ty) <+> pprCoreExpr expr, ptext SLIT("of") <+> ppr_bndr var <+> char '{'], nest 2 (sep (punctuate semi (map pprCoreAlt alts))), char '}' diff --git a/ghc/compiler/coreSyn/PprExternalCore.lhs b/ghc/compiler/coreSyn/PprExternalCore.lhs index 871f43cb43..dbcc86d153 100644 --- a/ghc/compiler/coreSyn/PprExternalCore.lhs +++ b/ghc/compiler/coreSyn/PprExternalCore.lhs @@ -56,6 +56,8 @@ ptdef (Newtype tcon tbinds rep ) = pcdef (Constr dcon tbinds tys) = (pname dcon) <+> (sep [hsep (map pattbind tbinds),sep (map paty tys)]) +pcdef (GadtConstr dcon ty) = + (pname dcon) <+> text "::" <+> pty ty pname id = text id @@ -123,7 +125,8 @@ pappexp e as = fsep (paexp e : map pa as) pexp (Lam b e) = char '\\' <+> plamexp [b] e pexp (Let vd e) = (text "%let" <+> pvdefg vd) $$ (text "%in" <+> pexp e) -pexp (Case e vb alts) = sep [text "%case" <+> paexp e, +-- gaw 2004 +pexp (Case e vb ty alts) = sep [text "%case" <+> parens (paty ty) <+> paexp e, text "%of" <+> pvbind vb] $$ (indent (braces (vcat (punctuate (char ';') (map palt alts))))) pexp (Coerce t e) = (text "%coerce" <+> paty t) $$ pexp e diff --git a/ghc/compiler/coreSyn/Subst.lhs b/ghc/compiler/coreSyn/Subst.lhs index dee369ceef..36b5de89ae 100644 --- a/ghc/compiler/coreSyn/Subst.lhs +++ b/ghc/compiler/coreSyn/Subst.lhs @@ -5,20 +5,13 @@ \begin{code} module Subst ( - -- In-scope set - InScopeSet, emptyInScopeSet, mkInScopeSet, - extendInScopeSet, extendInScopeSetList, - lookupInScope, elemInScopeSet, uniqAway, - - -- Substitution stuff - Subst, TyVarSubst, IdSubst, - emptySubst, mkSubst, substEnv, substInScope, - lookupSubst, lookupIdSubst, isEmptySubst, extendSubst, extendSubstList, + Subst, SubstResult(..), + emptySubst, mkSubst, substInScope, substTy, + lookupIdSubst, lookupTvSubst, isEmptySubst, + extendIdSubst, extendIdSubstList, extendTvSubst, extendTvSubstList, zapSubstEnv, setSubstEnv, - setInScope, - extendInScope, extendInScopeList, extendNewInScope, extendNewInScopeList, - isInScope, modifyInScope, + getTvSubst, getTvSubstEnv, setTvSubstEnv, bindSubst, unBindSubst, bindSubstList, unBindSubstList, @@ -26,17 +19,16 @@ module Subst ( simplBndr, simplBndrs, simplLetId, simplLamBndr, simplIdInfo, substAndCloneId, substAndCloneIds, substAndCloneRecIds, - -- Type stuff - mkTyVarSubst, mkTopTyVarSubst, - substTyWith, substTy, substTheta, deShadowTy, + setInScope, setInScopeSet, + extendInScope, extendInScopeIds, + isInScope, modifyInScope, -- Expression stuff - substExpr, substRules + substExpr, substRules, substId ) where #include "HsVersions.h" -import CmdLineOpts ( opt_PprStyle_Debug ) import CoreSyn ( Expr(..), Bind(..), Note(..), CoreExpr, CoreRules(..), CoreRule(..), isEmptyCoreRules, seqRules, hasUnfolding, noUnfolding, hasSomeUnfolding, @@ -44,10 +36,10 @@ import CoreSyn ( Expr(..), Bind(..), Note(..), CoreExpr, ) import CoreFVs ( exprFreeVars ) import CoreUtils ( exprIsTrivial ) -import TypeRep ( Type(..), TyNote(..) ) -- friend -import Type ( ThetaType, PredType(..), - tyVarsOfType, tyVarsOfTypes, mkAppTy, - ) + +import qualified Type ( substTy ) +import Type ( Type, tyVarsOfType, mkTyVarTy, + TvSubstEnv, TvSubst(..), substTyVar ) import VarSet import VarEnv import Var ( setVarUnique, isId, mustHaveLocalBinding ) @@ -62,108 +54,28 @@ import IdInfo ( IdInfo, vanillaIdInfo, WorkerInfo(..), workerExists, workerInfo, setWorkerInfo, WorkerInfo ) import BasicTypes ( OccInfo(..) ) -import Unique ( Unique, Uniquable(..), deriveUnique ) -import UniqSet ( elemUniqSet_Directly ) +import Unique ( Unique ) import UniqSupply ( UniqSupply, uniqFromSupply, uniqsFromSupply ) import Var ( Var, Id, TyVar, isTyVar ) import Outputable import PprCore () -- Instances -import UniqFM ( ufmToList ) -- Yuk (add a new op to VarEnv) -import Util ( mapAccumL, foldl2, seqList ) +import Util ( mapAccumL, foldl2 ) import FastTypes \end{code} %************************************************************************ %* * -\subsection{The in-scope set} -%* * -%************************************************************************ - -\begin{code} -data InScopeSet = InScope (VarEnv Var) FastInt - -- The Int# is a kind of hash-value used by uniqAway - -- For example, it might be the size of the set - -- INVARIANT: it's not zero; we use it as a multiplier in uniqAway - -emptyInScopeSet :: InScopeSet -emptyInScopeSet = InScope emptyVarSet 1# - -mkInScopeSet :: VarEnv Var -> InScopeSet -mkInScopeSet in_scope = InScope in_scope 1# - -extendInScopeSet :: InScopeSet -> Var -> InScopeSet -extendInScopeSet (InScope in_scope n) v = InScope (extendVarEnv in_scope v v) (n +# 1#) - -extendInScopeSetList :: InScopeSet -> [Var] -> InScopeSet -extendInScopeSetList (InScope in_scope n) vs - = InScope (foldl (\s v -> extendVarEnv s v v) in_scope vs) - (n +# iUnbox (length vs)) - -modifyInScopeSet :: InScopeSet -> Var -> Var -> InScopeSet --- Exploit the fact that the in-scope "set" is really a map --- Make old_v map to new_v -modifyInScopeSet (InScope in_scope n) old_v new_v = InScope (extendVarEnv in_scope old_v new_v) (n +# 1#) - -delInScopeSet :: InScopeSet -> Var -> InScopeSet -delInScopeSet (InScope in_scope n) v = InScope (in_scope `delVarEnv` v) n - -elemInScopeSet :: Var -> InScopeSet -> Bool -elemInScopeSet v (InScope in_scope n) = v `elemVarEnv` in_scope - -lookupInScope :: InScopeSet -> Var -> Var --- It's important to look for a fixed point --- When we see (case x of y { I# v -> ... }) --- we add [x -> y] to the in-scope set (Simplify.simplCaseBinder). --- When we lookup up an occurrence of x, we map to y, but then --- we want to look up y in case it has acquired more evaluation information by now. -lookupInScope (InScope in_scope n) v - = go v - where - go v = case lookupVarEnv in_scope v of - Just v' | v == v' -> v' -- Reached a fixed point - | otherwise -> go v' - Nothing -> WARN( mustHaveLocalBinding v, ppr v ) - v -\end{code} - -\begin{code} -uniqAway :: InScopeSet -> Var -> Var --- (uniqAway in_scope v) finds a unique that is not used in the --- in-scope set, and gives that to v. It starts with v's current unique, of course, --- in the hope that it won't have to change it, and thereafter uses a combination --- of that and the hash-code found in the in-scope set -uniqAway (InScope set n) var - | not (var `elemVarSet` set) = var -- Nothing to do - | otherwise = try 1# - where - orig_unique = getUnique var - try k -#ifdef DEBUG - | k ># 1000# - = pprPanic "uniqAway loop:" (ppr (iBox k) <+> text "tries" <+> ppr var <+> int (iBox n)) -#endif - | uniq `elemUniqSet_Directly` set = try (k +# 1#) -#ifdef DEBUG - | opt_PprStyle_Debug && k ># 3# - = pprTrace "uniqAway:" (ppr (iBox k) <+> text "tries" <+> ppr var <+> int (iBox n)) - setVarUnique var uniq -#endif - | otherwise = setVarUnique var uniq - where - uniq = deriveUnique orig_unique (iBox (n *# k)) -\end{code} - - -%************************************************************************ -%* * \subsection{Substitutions} %* * %************************************************************************ \begin{code} -data Subst = Subst InScopeSet -- In scope - SubstEnv -- Substitution itself +data Subst + = Subst InScopeSet -- Variables in in scope (both Ids and TyVars) + IdSubstEnv -- Substitution for Ids + TvSubstEnv -- Substitution for TyVars + -- INVARIANT 1: The (domain of the) in-scope set is a superset -- of the free vars of the range of the substitution -- that might possibly clash with locally-bound variables @@ -190,7 +102,14 @@ data Subst = Subst InScopeSet -- In scope -- other is an out-Id. So the substitution is idempotent in the sense -- that we *must not* repeatedly apply it.] -type IdSubst = Subst + +type IdSubstEnv = IdEnv SubstResult + +data SubstResult + = DoneEx CoreExpr -- Completed term + | DoneId Id OccInfo -- Completed term variable, with occurrence info; + -- only used by the simplifier + | ContEx Subst CoreExpr -- A suspended substitution \end{code} The general plan about the substitution and in-scope set for Ids is as follows @@ -232,90 +151,90 @@ The general plan about the substitution and in-scope set for Ids is as follows \begin{code} isEmptySubst :: Subst -> Bool -isEmptySubst (Subst _ env) = isEmptySubstEnv env +isEmptySubst (Subst _ id_env tv_env) = isEmptyVarEnv id_env && isEmptyVarEnv tv_env emptySubst :: Subst -emptySubst = Subst emptyInScopeSet emptySubstEnv +emptySubst = Subst emptyInScopeSet emptyVarEnv emptyVarEnv + +mkSubst :: InScopeSet -> Subst +mkSubst in_scope = Subst in_scope emptyVarEnv emptyVarEnv + +getTvSubst :: Subst -> TvSubst +getTvSubst (Subst in_scope _ tv_env) = TvSubst in_scope tv_env + +getTvSubstEnv :: Subst -> TvSubstEnv +getTvSubstEnv (Subst _ _ tv_env) = tv_env + +setTvSubstEnv :: Subst -> TvSubstEnv -> Subst +setTvSubstEnv (Subst in_scope ids _) tvs = Subst in_scope ids tvs -mkSubst :: InScopeSet -> SubstEnv -> Subst -mkSubst in_scope env = Subst in_scope env -substEnv :: Subst -> SubstEnv -substEnv (Subst _ env) = env substInScope :: Subst -> InScopeSet -substInScope (Subst in_scope _) = in_scope +substInScope (Subst in_scope _ _) = in_scope zapSubstEnv :: Subst -> Subst -zapSubstEnv (Subst in_scope env) = Subst in_scope emptySubstEnv +zapSubstEnv (Subst in_scope _ _) = Subst in_scope emptyVarEnv emptyVarEnv -- ToDo: add an ASSERT that fvs(subst-result) is already in the in-scope set -extendSubst :: Subst -> Var -> SubstResult -> Subst -extendSubst (Subst in_scope env) v r = Subst in_scope (extendSubstEnv env v r) - -extendSubstList :: Subst -> [Var] -> [SubstResult] -> Subst -extendSubstList (Subst in_scope env) v r = Subst in_scope (extendSubstEnvList env v r) - -lookupSubst :: Subst -> Var -> Maybe SubstResult -lookupSubst (Subst _ env) v = lookupSubstEnv env v - -lookupIdSubst :: Subst -> Id -> SubstResult --- Does the lookup in the in-scope set too -lookupIdSubst (Subst in_scope env) v - = case lookupSubstEnv env v of - Just (DoneId v' occ) -> DoneId (lookupInScope in_scope v') occ - Just res -> res - Nothing -> DoneId v' (idOccInfo v') - -- We don't use DoneId for LoopBreakers, so the idOccInfo is - -- very important! If isFragileOcc returned True for - -- loop breakers we could avoid this call, but at the expense - -- of adding more to the substitution, and building new Ids - -- in substId a bit more often than really necessary - where - v' = lookupInScope in_scope v +extendIdSubst :: Subst -> Id -> SubstResult -> Subst +extendIdSubst (Subst in_scope ids tvs) v r = Subst in_scope (extendVarEnv ids v r) tvs + +extendIdSubstList :: Subst -> [(Id, SubstResult)] -> Subst +extendIdSubstList (Subst in_scope ids tvs) prs = Subst in_scope (extendVarEnvList ids prs) tvs + +extendTvSubst :: Subst -> TyVar -> Type -> Subst +extendTvSubst (Subst in_scope ids tvs) v r = Subst in_scope ids (extendVarEnv tvs v r) +extendTvSubstList :: Subst -> [(TyVar,Type)] -> Subst +extendTvSubstList (Subst in_scope ids tvs) prs = Subst in_scope ids (extendVarEnvList tvs prs) + +lookupIdSubst :: Subst -> Id -> Maybe SubstResult +lookupIdSubst (Subst in_scope ids tvs) v = lookupVarEnv ids v + +lookupTvSubst :: Subst -> TyVar -> Maybe Type +lookupTvSubst (Subst _ ids tvs) v = lookupVarEnv tvs v + +------------------------------ isInScope :: Var -> Subst -> Bool -isInScope v (Subst in_scope _) = v `elemInScopeSet` in_scope +isInScope v (Subst in_scope _ _) = v `elemInScopeSet` in_scope modifyInScope :: Subst -> Var -> Var -> Subst -modifyInScope (Subst in_scope env) old_v new_v = Subst (modifyInScopeSet in_scope old_v new_v) env +modifyInScope (Subst in_scope ids tvs) old_v new_v + = Subst (modifyInScopeSet in_scope old_v new_v) ids tvs -- make old_v map to new_v extendInScope :: Subst -> Var -> Subst - -- Add a new variable as in-scope - -- Remember to delete any existing binding in the substitution! -extendInScope (Subst in_scope env) v = Subst (in_scope `extendInScopeSet` v) - (env `delSubstEnv` v) - -extendInScopeList :: Subst -> [Var] -> Subst -extendInScopeList (Subst in_scope env) vs = Subst (extendInScopeSetList in_scope vs) - (delSubstEnvList env vs) - --- The "New" variants are guaranteed to be adding freshly-allocated variables --- It's not clear that the gain (not needing to delete it from the substitution) --- is worth the extra proof obligation -extendNewInScope :: Subst -> Var -> Subst -extendNewInScope (Subst in_scope env) v = Subst (in_scope `extendInScopeSet` v) env +extendInScope (Subst in_scope ids tvs) v + = Subst (in_scope `extendInScopeSet` v) + (ids `delVarEnv` v) (tvs `delVarEnv` v) -extendNewInScopeList :: Subst -> [Var] -> Subst -extendNewInScopeList (Subst in_scope env) vs = Subst (in_scope `extendInScopeSetList` vs) env +extendInScopeIds :: Subst -> [Id] -> Subst +extendInScopeIds (Subst in_scope ids tvs) vs + = Subst (in_scope `extendInScopeSetList` vs) + (ids `delVarEnvList` vs) tvs ------------------------------- bindSubst :: Subst -> Var -> Var -> Subst -- Extend with a substitution, v1 -> Var v2 -- and extend the in-scopes with v2 -bindSubst (Subst in_scope env) old_bndr new_bndr +bindSubst (Subst in_scope ids tvs) old_bndr new_bndr + | isId old_bndr = Subst (in_scope `extendInScopeSet` new_bndr) - (extendSubstEnv env old_bndr subst_result) - where - subst_result | isId old_bndr = DoneEx (Var new_bndr) - | otherwise = DoneTy (TyVarTy new_bndr) + (extendVarEnv ids old_bndr (DoneEx (Var new_bndr))) + tvs + | otherwise + = Subst (in_scope `extendInScopeSet` new_bndr) + ids + (extendVarEnv tvs old_bndr (mkTyVarTy new_bndr)) unBindSubst :: Subst -> Var -> Var -> Subst -- Reverse the effect of bindSubst -- If old_bndr was already in the substitution, this doesn't quite work -unBindSubst (Subst in_scope env) old_bndr new_bndr - = Subst (in_scope `delInScopeSet` new_bndr) (delSubstEnv env old_bndr) +unBindSubst (Subst in_scope ids tvs) old_bndr new_bndr + = Subst (in_scope `delInScopeSet` new_bndr) + (delVarEnv ids old_bndr) + (delVarEnv tvs old_bndr) -- And the "List" forms bindSubstList :: Subst -> [Var] -> [Var] -> Subst @@ -328,16 +247,20 @@ unBindSubstList subst old_bndrs new_bndrs ------------------------------- +setInScopeSet :: Subst -> InScopeSet -> Subst +setInScopeSet (Subst _ ids tvs) in_scope + = Subst in_scope ids tvs + setInScope :: Subst -- Take env part from here - -> InScopeSet + -> Subst -- Take in-scope part from here -> Subst -setInScope (Subst in_scope1 env1) in_scope2 - = Subst in_scope2 env1 +setInScope (Subst _ ids tvs) (Subst in_scope _ _) + = Subst in_scope ids tvs -setSubstEnv :: Subst -- Take in-scope part from here - -> SubstEnv -- ... and env part from here +setSubstEnv :: Subst -- Take in-scope part from here + -> Subst -- ... and env part from here -> Subst -setSubstEnv (Subst in_scope1 _) env2 = Subst in_scope1 env2 +setSubstEnv s1 s2 = setInScope s2 s1 \end{code} Pretty printing, for debugging only @@ -347,141 +270,13 @@ instance Outputable SubstResult where ppr (DoneEx e) = ptext SLIT("DoneEx") <+> ppr e ppr (DoneId v _) = ptext SLIT("DoneId") <+> ppr v ppr (ContEx _ e) = ptext SLIT("ContEx") <+> ppr e - ppr (DoneTy t) = ptext SLIT("DoneTy") <+> ppr t - -instance Outputable SubstEnv where - ppr se = brackets (fsep (punctuate comma (map ppr_elt (ufmToList (substEnvEnv se))))) - where - ppr_elt (uniq,sr) = ppr uniq <+> ptext SLIT("->") <+> ppr sr instance Outputable Subst where - ppr (Subst (InScope in_scope _) se) - = ptext SLIT("<InScope =") <+> braces (fsep (map ppr (rngVarEnv in_scope))) - $$ ptext SLIT(" Subst =") <+> ppr se <> char '>' -\end{code} - -%************************************************************************ -%* * -\subsection{Type substitution} -%* * -%************************************************************************ - -\begin{code} -type TyVarSubst = Subst -- TyVarSubst are expected to have range elements - -- (We could have a variant of Subst, but it doesn't seem worth it.) - --- mkTyVarSubst generates the in-scope set from --- the types given; but it's just a thunk so with a bit of luck --- it'll never be evaluated -mkTyVarSubst :: [TyVar] -> [Type] -> Subst -mkTyVarSubst tyvars tys = Subst (mkInScopeSet (tyVarsOfTypes tys)) - (zipTyEnv tyvars tys) - --- mkTopTyVarSubst is called when doing top-level substitutions. --- Here we expect that the free vars of the range of the --- substitution will be empty. -mkTopTyVarSubst :: [TyVar] -> [Type] -> Subst -mkTopTyVarSubst tyvars tys = Subst emptyInScopeSet (zipTyEnv tyvars tys) - -zipTyEnv tyvars tys -#ifdef DEBUG - | length tyvars /= length tys - = pprTrace "mkTopTyVarSubst" (ppr tyvars $$ ppr tys) emptySubstEnv - | otherwise -#endif - = zip_ty_env tyvars tys emptySubstEnv - --- Later substitutions in the list over-ride earlier ones -zip_ty_env [] [] env = env -zip_ty_env (tv:tvs) (ty:tys) env = zip_ty_env tvs tys (extendSubstEnv env tv (DoneTy ty)) - -- There used to be a special case for when - -- ty == TyVarTy tv - -- (a not-uncommon case) in which case the substitution was dropped. - -- But the type-tidier changes the print-name of a type variable without - -- changing the unique, and that led to a bug. Why? Pre-tidying, we had - -- a type {Foo t}, where Foo is a one-method class. So Foo is really a newtype. - -- And it happened that t was the type variable of the class. Post-tiding, - -- it got turned into {Foo t2}. The ext-core printer expanded this using - -- sourceTypeRep, but that said "Oh, t == t2" because they have the same unique, - -- and so generated a rep type mentioning t not t2. - -- - -- Simplest fix is to nuke the "optimisation" -\end{code} - -substTy works with general Substs, so that it can be called from substExpr too. - -\begin{code} -substTyWith :: [TyVar] -> [Type] -> Type -> Type -substTyWith tvs tys = substTy (mkTyVarSubst tvs tys) - -substTy :: Subst -> Type -> Type -substTy subst ty | isEmptySubst subst = ty - | otherwise = subst_ty subst ty - -deShadowTy :: Type -> Type -- Remove any shadowing from the type -deShadowTy ty = subst_ty emptySubst ty - -substTheta :: TyVarSubst -> ThetaType -> ThetaType -substTheta subst theta - | isEmptySubst subst = theta - | otherwise = map (substPred subst) theta - -substPred :: TyVarSubst -> PredType -> PredType -substPred subst (IParam n ty) = IParam n (subst_ty subst ty) -substPred subst (ClassP clas tys) = ClassP clas (map (subst_ty subst) tys) - -subst_ty subst ty - = go ty - where - go (TyConApp tc tys) = let args = map go tys - in args `seqList` TyConApp tc args - - go (NewTcApp tc tys) = let args = map go tys - in args `seqList` NewTcApp tc args - - go (PredTy p) = PredTy $! (substPred subst p) - - go (NoteTy (SynNote ty1) ty2) = NoteTy (SynNote $! (go ty1)) $! (go ty2) - go (NoteTy (FTVNote _) ty2) = go ty2 -- Discard the free tyvar note - - go (FunTy arg res) = (FunTy $! (go arg)) $! (go res) - go (AppTy fun arg) = mkAppTy (go fun) $! (go arg) - go ty@(TyVarTy tv) = case (lookupSubst subst tv) of - Nothing -> ty - Just (DoneTy ty') -> ty' - - go (ForAllTy tv ty) = case substTyVar subst tv of - (subst', tv') -> ForAllTy tv' $! (subst_ty subst' ty) -\end{code} - -Here is where we invent a new binder if necessary. - -\begin{code} -substTyVar :: Subst -> TyVar -> (Subst, TyVar) -substTyVar subst@(Subst in_scope env) old_var - | old_var == new_var -- No need to clone - -- But we *must* zap any current substitution for the variable. - -- For example: - -- (\x.e) with id_subst = [x |-> e'] - -- Here we must simply zap the substitution for x - -- - -- The new_id isn't cloned, but it may have a different type - -- etc, so we must return it, not the old id - = (Subst (in_scope `extendInScopeSet` new_var) - (delSubstEnv env old_var), - new_var) - - | otherwise -- The new binder is in scope so - -- we'd better rename it away from the in-scope variables - -- Extending the substitution to do this renaming also - -- has the (correct) effect of discarding any existing - -- substitution for that variable - = (Subst (in_scope `extendInScopeSet` new_var) - (extendSubstEnv env old_var (DoneTy (TyVarTy new_var))), - new_var) - where - new_var = uniqAway in_scope old_var - -- The uniqAway part makes sure the new variable is not already in scope + ppr (Subst in_scope ids tvs) + = ptext SLIT("<InScope =") <+> braces (fsep (map ppr (varEnvElts (getInScopeVars in_scope)))) + $$ ptext SLIT(" IdSubst =") <+> ppr ids + $$ ptext SLIT(" TvSubst =") <+> ppr tvs + <> char '>' \end{code} @@ -513,9 +308,7 @@ substExpr subst expr = go expr where - go (Var v) = -- See the notes at the top, with the Subst data type declaration - case lookupIdSubst subst v of - + go (Var v) = case substId subst v of ContEx env' e' -> substExpr (setSubstEnv subst env') e' DoneId v _ -> Var v DoneEx e' -> e' @@ -538,10 +331,9 @@ substExpr subst expr (subst', bndrs') = substRecBndrs subst (map fst pairs) pairs' = bndrs' `zip` rhss' rhss' = map (substExpr subst' . snd) pairs - - go (Case scrut bndr alts) = Case (go scrut) bndr' (map (go_alt subst') alts) - where - (subst', bndr') = substBndr subst bndr + go (Case scrut bndr ty alts) = Case (go scrut) bndr' (go_ty ty) (map (go_alt subst') alts) + where + (subst', bndr') = substBndr subst bndr go_alt subst (con, bndrs, rhs) = (con, bndrs', substExpr subst' rhs) where @@ -552,6 +344,31 @@ substExpr subst expr go_ty ty = substTy subst ty +substId :: Subst -> Id -> SubstResult +substId (Subst in_scope ids tvs) v + = case lookupVarEnv ids v of + Just (DoneId v occ) -> DoneId (lookup v) occ + Just res -> res + Nothing -> let v' = lookup v + in DoneId v' (idOccInfo v') + -- Note [idOccInfo] + -- We don't use DoneId for LoopBreakers, so the idOccInfo is + -- very important! If isFragileOcc returned True for + -- loop breakers we could avoid this call, but at the expense + -- of adding more to the substitution, and building new Ids + -- in substId a bit more often than really necessary + where + -- Get the most up-to-date thing from the in-scope set + -- Even though it isn't in the substitution, it may be in + -- the in-scope set with a different type (we only use the + -- substitution if the unique changes). + lookup v = case lookupInScope in_scope v of + Just v' -> v' + Nothing -> WARN( mustHaveLocalBinding v, ppr v ) v + + +substTy :: Subst -> Type -> Type +substTy subst ty = Type.substTy (getTvSubst subst) ty \end{code} @@ -571,7 +388,7 @@ simplBndr :: Subst -> Var -> (Subst, Var) -- The substitution is extended only if the variable is cloned, because -- we *don't* need to use it to track occurrence info. simplBndr subst bndr - | isTyVar bndr = substTyVar subst bndr + | isTyVar bndr = subst_tv subst bndr | otherwise = subst_id False subst subst bndr simplBndrs :: Subst -> [Var] -> (Subst, [Var]) @@ -603,8 +420,8 @@ simplLetId :: Subst -> Id -> (Subst, Id) -- if the unique changed, *or* -- if there's interesting occurrence info -simplLetId subst@(Subst in_scope env) old_id - = (Subst (in_scope `extendInScopeSet` new_id) new_env, new_id) +simplLetId subst@(Subst in_scope env tvs) old_id + = (Subst (in_scope `extendInScopeSet` new_id) new_env tvs, new_id) where old_info = idInfo old_id id1 = uniqAway in_scope old_id @@ -616,9 +433,9 @@ simplLetId subst@(Subst in_scope env) old_id -- See the notes with substTyVar for the delSubstEnv occ_info = occInfo old_info new_env | new_id /= old_id || isFragileOcc occ_info - = extendSubstEnv env old_id (DoneId new_id occ_info) + = extendVarEnv env old_id (DoneId new_id occ_info) | otherwise - = delSubstEnv env old_id + = delVarEnv env old_id simplIdInfo :: Subst -> IdInfo -> IdInfo -- Used by the simplifier to compute new IdInfo for a let(rec) binder, @@ -636,7 +453,7 @@ simplIdInfo subst old_info substBndr :: Subst -> Var -> (Subst, Var) substBndr subst bndr - | isTyVar bndr = substTyVar subst bndr + | isTyVar bndr = subst_tv subst bndr | otherwise = subst_id True {- keep fragile info -} subst subst bndr substBndrs :: Subst -> [Var] -> (Subst, [Var]) @@ -654,6 +471,13 @@ substRecBndrs subst bndrs \begin{code} +subst_tv :: Subst -> TyVar -> (Subst, TyVar) +-- Unpackage and re-package for substTyVar +subst_tv (Subst in_scope id_env tv_env) tv + = case substTyVar (TvSubst in_scope tv_env) tv of + (TvSubst in_scope' tv_env', tv') + -> (Subst in_scope' id_env tv_env', tv') + subst_id :: Bool -- True <=> keep fragile info -> Subst -- Substitution to use for the IdInfo -> Subst -> Id -- Substitition and Id to transform @@ -670,8 +494,8 @@ subst_id :: Bool -- True <=> keep fragile info -- In this case, the var in the DoneId is the same as the -- var returned -subst_id keep_fragile rec_subst subst@(Subst in_scope env) old_id - = (Subst (in_scope `extendInScopeSet` new_id) new_env, new_id) +subst_id keep_fragile rec_subst subst@(Subst in_scope env tvs) old_id + = (Subst (in_scope `extendInScopeSet` new_id) new_env tvs, new_id) where -- id1 is cloned if necessary id1 = uniqAway in_scope old_id @@ -687,9 +511,9 @@ subst_id keep_fragile rec_subst subst@(Subst in_scope env) old_id -- Extend the substitution if the unique has changed -- See the notes with substTyVar for the delSubstEnv new_env | new_id /= old_id - = extendSubstEnv env old_id (DoneId new_id (idOccInfo old_id)) + = extendVarEnv env old_id (DoneId new_id (idOccInfo old_id)) | otherwise - = delSubstEnv env old_id + = delVarEnv env old_id \end{code} Now a variant that unconditionally allocates a new unique. @@ -700,14 +524,14 @@ subst_clone_id :: Subst -- Substitution to use (lazily) for the rules and work -> Subst -> (Id, Unique) -- Substitition and Id to transform -> (Subst, Id) -- Transformed pair -subst_clone_id rec_subst subst@(Subst in_scope env) (old_id, uniq) - = (Subst (in_scope `extendInScopeSet` new_id) new_env, new_id) +subst_clone_id rec_subst subst@(Subst in_scope env tvs) (old_id, uniq) + = (Subst (in_scope `extendInScopeSet` new_id) new_env tvs, new_id) where id1 = setVarUnique old_id uniq id2 = substIdType subst id1 new_id = maybeModifyIdInfo (substIdInfo False rec_subst) id2 - new_env = extendSubstEnv env old_id (DoneId new_id NoOccInfo) + new_env = extendVarEnv env old_id (DoneId new_id NoOccInfo) substAndCloneIds :: Subst -> UniqSupply -> [Id] -> (Subst, [Id]) substAndCloneIds subst us ids @@ -721,7 +545,7 @@ substAndCloneRecIds subst us ids (ids `zip` uniqsFromSupply us) substAndCloneId :: Subst -> UniqSupply -> Id -> (Subst, Id) -substAndCloneId subst@(Subst in_scope env) us old_id +substAndCloneId subst us old_id = subst_clone_id subst subst (old_id, uniqFromSupply us) \end{code} @@ -779,9 +603,9 @@ substIdInfo keep_fragile subst info ------------------ substIdType :: Subst -> Id -> Id -substIdType subst@(Subst in_scope env) id - | noTypeSubst env || isEmptyVarSet (tyVarsOfType old_ty) = id - | otherwise = setIdType id (substTy subst old_ty) +substIdType subst@(Subst in_scope id_env tv_env) id + | isEmptyVarEnv tv_env || isEmptyVarSet (tyVarsOfType old_ty) = id + | otherwise = setIdType id (Type.substTy (TvSubst in_scope tv_env) old_ty) -- The tyVarsOfType is cheaper than it looks -- because we cache the free tyvars of the type -- in a Note in the id's type itself @@ -796,15 +620,15 @@ substWorker :: Subst -> WorkerInfo -> WorkerInfo substWorker subst NoWorker = NoWorker substWorker subst (HasWorker w a) - = case lookupIdSubst subst w of - (DoneId w1 _) -> HasWorker w1 a - (DoneEx (Var w1)) -> HasWorker w1 a - (DoneEx other) -> WARN( not (exprIsTrivial other), text "substWorker: DoneEx" <+> ppr w ) - NoWorker -- Worker has got substituted away altogether + = case substId subst w of + DoneId w1 _ -> HasWorker w1 a + DoneEx (Var w1) -> HasWorker w1 a + DoneEx other -> WARN( not (exprIsTrivial other), text "substWorker: DoneEx" <+> ppr w ) + NoWorker -- Worker has got substituted away altogether -- This can happen if it's trivial, -- via postInlineUnconditionally - (ContEx se1 e) -> WARN( True, text "substWorker: ContEx" <+> ppr w <+> ppr e) - NoWorker -- Ditto + ContEx se1 e -> WARN( True, text "substWorker: ContEx" <+> ppr w <+> ppr e) + NoWorker -- Ditto ------------------ substUnfolding subst NoUnfolding = NoUnfolding @@ -837,9 +661,12 @@ substRules subst (Rules rules rhs_fvs) substVarSet subst fvs = foldVarSet (unionVarSet . subst_fv subst) emptyVarSet fvs where - subst_fv subst fv = case lookupIdSubst subst fv of - DoneId fv' _ -> unitVarSet fv' - DoneEx expr -> exprFreeVars expr - DoneTy ty -> tyVarsOfType ty - ContEx se' expr -> substVarSet (setSubstEnv subst se') (exprFreeVars expr) + subst_fv subst fv + | isId fv = case substId subst fv of + DoneId fv' _ -> unitVarSet fv' + DoneEx expr -> exprFreeVars expr + ContEx se' expr -> substVarSet (setSubstEnv subst se') (exprFreeVars expr) + | otherwise = case lookupTvSubst subst fv of + Nothing -> unitVarSet fv + Just ty -> substVarSet subst (tyVarsOfType ty) \end{code} diff --git a/ghc/compiler/deSugar/Check.lhs b/ghc/compiler/deSugar/Check.lhs index aed32b6bf6..e03dd4310f 100644 --- a/ghc/compiler/deSugar/Check.lhs +++ b/ghc/compiler/deSugar/Check.lhs @@ -13,9 +13,9 @@ module Check ( check , ExhaustivePat ) where import HsSyn import TcHsSyn ( hsPatType ) import TcType ( tcTyConAppTyCon ) -import DsUtils ( EquationInfo(..), MatchResult(..), EqnSet, - CanItFail(..), tidyLitPat, tidyNPat, - ) +import DsUtils ( EquationInfo(..), MatchResult(..), + CanItFail(..), firstPat ) +import MatchLit ( tidyLitPat, tidyNPat ) import Id ( Id, idType ) import DataCon ( DataCon, dataConTyCon, dataConOrigArgTys, dataConFieldLabels ) import Name ( Name, mkInternalName, getOccName, isDataSymOcc, getName, mkVarOcc ) @@ -96,17 +96,22 @@ Then we need to use InPats. Juan Quintela 5 JUL 1998\\ User-friendliness and compiler writers are no friends. \end{quotation} -\begin{code} +\begin{code} type WarningPat = InPat Name type ExhaustivePat = ([WarningPat], [(Name, [HsLit])]) +type EqnNo = Int +type EqnSet = UniqSet EqnNo -check :: [EquationInfo] -> ([ExhaustivePat],EqnSet) -check qs = (untidy_warns, incomplete) +check :: [EquationInfo] -> ([ExhaustivePat], [EquationInfo]) + -- Second result is the shadowed equations +check qs = (untidy_warns, shadowed_eqns) where - (warns, incomplete) = check' (simplify_eqns qs) + (warns, used_nos) = check' ([1..] `zip` map simplify_eqn qs) untidy_warns = map untidy_exhaustive warns + shadowed_eqns = [eqn | (eqn,i) <- qs `zip` [1..], + not (i `elementOfUniqSet` used_nos)] untidy_exhaustive :: ExhaustivePat -> ExhaustivePat untidy_exhaustive ([pat], messages) = @@ -184,21 +189,19 @@ There are several cases: \begin{code} -check' :: [EquationInfo] -> ([ExhaustivePat],EqnSet) -check' [] = ([([],[])],emptyUniqSet) +check' :: [(EqnNo, EquationInfo)] -> ([ExhaustivePat], EqnSet) +check' [] = ([([],[])],emptyUniqSet) -check' [EqnInfo n ctx ps (MatchResult CanFail _)] +check' [(n, EqnInfo { eqn_pats = ps, eqn_rhs = MatchResult CanFail _ })] | all_vars ps = ([(takeList ps (repeat nlWildPat),[])], unitUniqSet n) -check' qs@((EqnInfo n ctx ps (MatchResult CanFail _)):rs) +check' ((n, EqnInfo { eqn_pats = ps, eqn_rhs = MatchResult CanFail _}) : rs) | all_vars ps = (pats, addOneToUniqSet indexs n) where (pats,indexs) = check' rs -check' qs@((EqnInfo n ctx ps result):_) +check' qs@((n, EqnInfo { eqn_pats = ps }) : _) | all_vars ps = ([], unitUniqSet n) --- | nplusk = panic "Check.check': Work in progress: nplusk" --- | npat = panic "Check.check': Work in progress: npat ?????" | literals = split_by_literals qs | constructors = split_by_constructor qs | only_vars = first_column_only_vars qs @@ -206,12 +209,10 @@ check' qs@((EqnInfo n ctx ps result):_) where -- Note: RecPats will have been simplified to ConPats -- at this stage. - first_pats = ASSERT2( okGroup qs, pprGroup qs ) map firstPat qs + first_pats = ASSERT2( okGroup qs, pprGroup qs ) map firstPatN qs constructors = any is_con first_pats literals = any is_lit first_pats only_vars = all is_var first_pats --- npat = or (map is_npat qs) --- nplusk = or (map is_nplusk qs) \end{code} Here begins the code to deal with literals, we need to split the matrix @@ -219,7 +220,7 @@ in different matrix beginning by each literal and a last matrix with the rest of values. \begin{code} -split_by_literals :: [EquationInfo] -> ([ExhaustivePat],EqnSet) +split_by_literals :: [(EqnNo, EquationInfo)] -> ([ExhaustivePat], EqnSet) split_by_literals qs = process_literals used_lits qs where used_lits = get_used_lits qs @@ -229,12 +230,11 @@ split_by_literals qs = process_literals used_lits qs in the column of the matrix. \begin{code} -process_explicit_literals :: [HsLit] -> [EquationInfo] -> ([ExhaustivePat],EqnSet) +process_explicit_literals :: [HsLit] -> [(EqnNo, EquationInfo)] -> ([ExhaustivePat],EqnSet) process_explicit_literals lits qs = (concat pats, unionManyUniqSets indexs) where pats_indexs = map (\x -> construct_literal_matrix x qs) lits (pats,indexs) = unzip pats_indexs - \end{code} @@ -244,14 +244,14 @@ must be one Variable to be complete. \begin{code} -process_literals :: [HsLit] -> [EquationInfo] -> ([ExhaustivePat],EqnSet) +process_literals :: [HsLit] -> [(EqnNo, EquationInfo)] -> ([ExhaustivePat],EqnSet) process_literals used_lits qs - | null default_eqns = ([make_row_vars used_lits (head qs)]++pats,indexs) + | null default_eqns = ([make_row_vars used_lits (head qs)] ++ pats,indexs) | otherwise = (pats_default,indexs_default) where (pats,indexs) = process_explicit_literals used_lits qs default_eqns = ASSERT2( okGroup qs, pprGroup qs ) - map remove_var (filter (is_var . firstPat) qs) + [remove_var q | q <- qs, is_var (firstPatN q)] (pats',indexs') = check' default_eqns pats_default = [(nlWildPat:ps,constraints) | (ps,constraints) <- (pats')] ++ pats indexs_default = unionUniqSets indexs' indexs @@ -261,7 +261,7 @@ Here we have selected the literal and we will select all the equations that begins for that literal and create a new matrix. \begin{code} -construct_literal_matrix :: HsLit -> [EquationInfo] -> ([ExhaustivePat],EqnSet) +construct_literal_matrix :: HsLit -> [(EqnNo, EquationInfo)] -> ([ExhaustivePat],EqnSet) construct_literal_matrix lit qs = (map (\ (xs,ys) -> (new_lit:xs,ys)) pats,indexs) where @@ -269,42 +269,37 @@ construct_literal_matrix lit qs = new_lit = nlLitPat lit remove_first_column_lit :: HsLit - -> [EquationInfo] - -> [EquationInfo] + -> [(EqnNo, EquationInfo)] + -> [(EqnNo, EquationInfo)] remove_first_column_lit lit qs = ASSERT2( okGroup qs, pprGroup qs ) - map shift_pat (filter (is_var_lit lit . firstPat) qs) + [(n, shift_pat eqn) | q@(n,eqn) <- qs, is_var_lit lit (firstPatN q)] where - shift_pat (EqnInfo n ctx [] result) = panic "Check.shift_var: no patterns" - shift_pat (EqnInfo n ctx (_:ps) result) = EqnInfo n ctx ps result - + shift_pat eqn@(EqnInfo { eqn_pats = _:ps}) = eqn { eqn_pats = ps } + shift_pat eqn@(EqnInfo { eqn_pats = []}) = panic "Check.shift_var: no patterns" \end{code} This function splits the equations @qs@ in groups that deal with the same constructor. \begin{code} - -split_by_constructor :: [EquationInfo] -> ([ExhaustivePat],EqnSet) - +split_by_constructor :: [(EqnNo, EquationInfo)] -> ([ExhaustivePat], EqnSet) split_by_constructor qs | notNull unused_cons = need_default_case used_cons unused_cons qs | otherwise = no_need_default_case used_cons qs where used_cons = get_used_cons qs unused_cons = get_unused_cons used_cons - \end{code} The first column of the patterns matrix only have vars, then there is nothing to do. \begin{code} -first_column_only_vars :: [EquationInfo] -> ([ExhaustivePat],EqnSet) +first_column_only_vars :: [(EqnNo, EquationInfo)] -> ([ExhaustivePat],EqnSet) first_column_only_vars qs = (map (\ (xs,ys) -> (nlWildPat:xs,ys)) pats,indexs) where - (pats,indexs) = check' (map remove_var qs) - + (pats, indexs) = check' (map remove_var qs) \end{code} This equation takes a matrix of patterns and split the equations by @@ -316,19 +311,20 @@ constructors or not explicitly. The reasoning is similar to @process_literals@, the difference is that here the default case is not always needed. \begin{code} -no_need_default_case :: [Pat Id] -> [EquationInfo] -> ([ExhaustivePat],EqnSet) +no_need_default_case :: [Pat Id] -> [(EqnNo, EquationInfo)] -> ([ExhaustivePat],EqnSet) no_need_default_case cons qs = (concat pats, unionManyUniqSets indexs) where pats_indexs = map (\x -> construct_matrix x qs) cons (pats,indexs) = unzip pats_indexs -need_default_case :: [Pat Id] -> [DataCon] -> [EquationInfo] -> ([ExhaustivePat],EqnSet) +need_default_case :: [Pat Id] -> [DataCon] -> [(EqnNo, EquationInfo)] -> ([ExhaustivePat],EqnSet) need_default_case used_cons unused_cons qs | null default_eqns = (pats_default_no_eqns,indexs) | otherwise = (pats_default,indexs_default) where (pats,indexs) = no_need_default_case used_cons qs - default_eqns = ASSERT2( okGroup qs, pprGroup qs ) map remove_var (filter (is_var . firstPat) qs) + default_eqns = ASSERT2( okGroup qs, pprGroup qs ) + [remove_var q | q <- qs, is_var (firstPatN q)] (pats',indexs') = check' default_eqns pats_default = [(make_whole_con c:ps,constraints) | c <- unused_cons, (ps,constraints) <- pats'] ++ pats @@ -336,7 +332,7 @@ need_default_case used_cons unused_cons qs pats_default_no_eqns = [(make_whole_con c:new_wilds,[]) | c <- unused_cons] ++ pats indexs_default = unionUniqSets indexs' indexs -construct_matrix :: Pat Id -> [EquationInfo] -> ([ExhaustivePat],EqnSet) +construct_matrix :: Pat Id -> [(EqnNo, EquationInfo)] -> ([ExhaustivePat],EqnSet) construct_matrix con qs = (map (make_con con) pats,indexs) where @@ -359,41 +355,47 @@ is transformed in: \begin{code} remove_first_column :: Pat Id -- Constructor - -> [EquationInfo] - -> [EquationInfo] -remove_first_column (ConPatOut con (PrefixCon con_pats) _ _ _) qs + -> [(EqnNo, EquationInfo)] + -> [(EqnNo, EquationInfo)] +remove_first_column (ConPatOut con _ _ _ (PrefixCon con_pats) _) qs = ASSERT2( okGroup qs, pprGroup qs ) - map shift_var (filter (is_var_con con . firstPat) qs) + [(n, shift_var eqn) | q@(n, eqn) <- qs, is_var_con con (firstPatN q)] where new_wilds = [WildPat (hsPatType arg_pat) | arg_pat <- con_pats] - shift_var (EqnInfo n ctx (ConPatOut _ (PrefixCon ps') _ _ _:ps) result) = - EqnInfo n ctx (map unLoc ps'++ps) result - shift_var (EqnInfo n ctx (WildPat _ :ps) result) = - EqnInfo n ctx (new_wilds ++ ps) result + shift_var eqn@(EqnInfo { eqn_pats = ConPatOut _ _ _ _ (PrefixCon ps') _ : ps}) + = eqn { eqn_pats = map unLoc ps' ++ ps } + shift_var eqn@(EqnInfo { eqn_pats = WildPat _ : ps }) + = eqn { eqn_pats = new_wilds ++ ps } shift_var _ = panic "Check.Shift_var:No done" -make_row_vars :: [HsLit] -> EquationInfo -> ExhaustivePat -make_row_vars used_lits (EqnInfo _ _ pats _ ) = - (nlVarPat new_var:takeList (tail pats) (repeat nlWildPat),[(new_var,used_lits)]) - where new_var = hash_x +make_row_vars :: [HsLit] -> (EqnNo, EquationInfo) -> ExhaustivePat +make_row_vars used_lits (_, EqnInfo { eqn_pats = pats}) + = (nlVarPat new_var:takeList (tail pats) (repeat nlWildPat),[(new_var,used_lits)]) + where + new_var = hash_x hash_x = mkInternalName unboundKey {- doesn't matter much -} (mkVarOcc FSLIT("#x")) noSrcLoc -make_row_vars_for_constructor :: EquationInfo -> [WarningPat] -make_row_vars_for_constructor (EqnInfo _ _ pats _ ) = takeList (tail pats) (repeat nlWildPat) +make_row_vars_for_constructor :: (EqnNo, EquationInfo) -> [WarningPat] +make_row_vars_for_constructor (_, EqnInfo { eqn_pats = pats}) + = takeList (tail pats) (repeat nlWildPat) compare_cons :: Pat Id -> Pat Id -> Bool -compare_cons (ConPatOut id1 _ _ _ _) (ConPatOut id2 _ _ _ _) = id1 == id2 +compare_cons (ConPatOut id1 _ _ _ _ _) (ConPatOut id2 _ _ _ _ _) = id1 == id2 remove_dups :: [Pat Id] -> [Pat Id] remove_dups [] = [] remove_dups (x:xs) | or (map (\y -> compare_cons x y) xs) = remove_dups xs | otherwise = x : remove_dups xs -get_used_cons :: [EquationInfo] -> [Pat Id] -get_used_cons qs = remove_dups [con | (EqnInfo _ _ (con@(ConPatOut _ _ _ _ _):_) _) <- qs ] +get_used_cons :: [(EqnNo, EquationInfo)] -> [Pat Id] +get_used_cons qs = remove_dups [pat | q <- qs, let pat = firstPatN q, + isConPatOut pat] + +isConPatOut (ConPatOut {}) = True +isConPatOut other = False remove_dups' :: [HsLit] -> [HsLit] remove_dups' [] = [] @@ -401,27 +403,27 @@ remove_dups' (x:xs) | x `elem` xs = remove_dups' xs | otherwise = x : remove_dups' xs -get_used_lits :: [EquationInfo] -> [HsLit] +get_used_lits :: [(EqnNo, EquationInfo)] -> [HsLit] get_used_lits qs = remove_dups' all_literals where all_literals = get_used_lits' qs -get_used_lits' :: [EquationInfo] -> [HsLit] +get_used_lits' :: [(EqnNo, EquationInfo)] -> [HsLit] get_used_lits' [] = [] -get_used_lits' ((EqnInfo _ _ ((LitPat lit):_) _):qs) = - lit : get_used_lits qs -get_used_lits' ((EqnInfo _ _ ((NPatOut lit _ _):_) _):qs) = - lit : get_used_lits qs -get_used_lits' (q:qs) = - get_used_lits qs +get_used_lits' (q:qs) + | LitPat lit <- first_pat = lit : get_used_lits qs + | NPatOut lit _ _ <- first_pat = lit : get_used_lits qs + | otherwise = get_used_lits qs + where + first_pat = firstPatN q get_unused_cons :: [Pat Id] -> [DataCon] get_unused_cons used_cons = unused_cons where - (ConPatOut _ _ ty _ _) = head used_cons + (ConPatOut _ _ _ _ _ ty) = head used_cons ty_con = tcTyConAppTyCon ty -- Newtype observable all_cons = tyConDataCons ty_con - used_cons_as_id = map (\ (ConPatOut d _ _ _ _) -> d) used_cons + used_cons_as_id = map (\ (ConPatOut d _ _ _ _ _) -> d) used_cons unused_cons = uniqSetToList (mkUniqSet all_cons `minusUniqSet` mkUniqSet used_cons_as_id) @@ -430,19 +432,15 @@ all_vars [] = True all_vars (WildPat _:ps) = all_vars ps all_vars _ = False -remove_var :: EquationInfo -> EquationInfo -remove_var (EqnInfo n ctx (WildPat _:ps) result) = EqnInfo n ctx ps result -remove_var _ = - panic "Check.remove_var: equation does not begin with a variable" +remove_var :: (EqnNo, EquationInfo) -> (EqnNo, EquationInfo) +remove_var (n, eqn@(EqnInfo { eqn_pats = WildPat _ : ps})) = (n, eqn { eqn_pats = ps }) +remove_var _ = panic "Check.remove_var: equation does not begin with a variable" ----------------------- -eqnPats :: EquationInfo -> [Pat Id] -eqnPats (EqnInfo _ _ ps _) = ps - -firstPat :: EquationInfo -> Pat Id -firstPat eqn_info = head (eqnPats eqn_info) +eqnPats :: (EqnNo, EquationInfo) -> [Pat Id] +eqnPats (_, eqn) = eqn_pats eqn -okGroup :: [EquationInfo] -> Bool +okGroup :: [(EqnNo, EquationInfo)] -> Bool -- True if all equations have at least one pattern, and -- all have the same number of patterns okGroup [] = True @@ -454,8 +452,12 @@ okGroup (e:es) = n_pats > 0 && and [length (eqnPats e) == n_pats | e <- es] pprGroup es = vcat (map pprEqnInfo es) pprEqnInfo e = ppr (eqnPats e) + +firstPatN :: (EqnNo, EquationInfo) -> Pat Id +firstPatN (_, eqn) = firstPat eqn + is_con :: Pat Id -> Bool -is_con (ConPatOut _ _ _ _ _) = True +is_con (ConPatOut _ _ _ _ _ _) = True is_con _ = False is_lit :: Pat Id -> Bool @@ -463,22 +465,14 @@ is_lit (LitPat _) = True is_lit (NPatOut _ _ _) = True is_lit _ = False -is_npat :: Pat Id -> Bool -is_npat (NPatOut _ _ _) = True -is_npat _ = False - -is_nplusk :: Pat Id -> Bool -is_nplusk (NPlusKPatOut _ _ _ _) = True -is_nplusk _ = False - is_var :: Pat Id -> Bool is_var (WildPat _) = True is_var _ = False is_var_con :: DataCon -> Pat Id -> Bool -is_var_con con (WildPat _) = True -is_var_con con (ConPatOut id _ _ _ _) | id == con = True -is_var_con con _ = False +is_var_con con (WildPat _) = True +is_var_con con (ConPatOut id _ _ _ _ _) | id == con = True +is_var_con con _ = False is_var_lit :: HsLit -> Pat Id -> Bool is_var_lit lit (WildPat _) = True @@ -540,13 +534,12 @@ make_list p (ListPat ps ty) = ListPat (p:ps) ty make_list _ _ = panic "Check.make_list: Invalid argument" make_con :: Pat Id -> ExhaustivePat -> ExhaustivePat -make_con (ConPatOut id _ _ _ _) (lp:lq:ps, constraints) +make_con (ConPatOut id _ _ _ _ _) (lp:lq:ps, constraints) | return_list id q = (noLoc (make_list lp q) : ps, constraints) | isInfixCon id = (nlInfixConPat (getName id) lp lq : ps, constraints) - where p = unLoc lp - q = unLoc lq + where q = unLoc lq -make_con (ConPatOut id (PrefixCon pats) _ _ _) (ps, constraints) +make_con (ConPatOut id _ _ _ (PrefixCon pats) _) (ps, constraints) | isTupleTyCon tc = (noLoc (TuplePat pats_con (tupleTyConBoxity tc)) : rest_pats, constraints) | isPArrFakeCon id = (noLoc (PArrPat pats_con placeHolderType) : rest_pats, constraints) | otherwise = (nlConPat name pats_con : rest_pats, constraints) @@ -576,12 +569,8 @@ constraints. \begin{code} -simplify_eqns :: [EquationInfo] -> [EquationInfo] -simplify_eqns [] = [] -simplify_eqns ((EqnInfo n ctx pats result):qs) = - (EqnInfo n ctx pats' result) : simplify_eqns qs - where - pats' = map simplify_pat pats +simplify_eqn :: EquationInfo -> EquationInfo +simplify_eqn eqn = eqn { eqn_pats = map simplify_pat (eqn_pats eqn) } simplify_lpat :: LPat Id -> LPat Id simplify_lpat p = fmap simplify_pat p @@ -589,13 +578,14 @@ simplify_lpat p = fmap simplify_pat p simplify_pat :: Pat Id -> Pat Id simplify_pat pat@(WildPat gt) = pat simplify_pat (VarPat id) = WildPat (idType id) +simplify_pat (VarPatOut id _) = WildPat (idType id) -- Ignore the bindings +simplify_pat (ParPat p) = unLoc (simplify_lpat p) +simplify_pat (LazyPat p) = unLoc (simplify_lpat p) +simplify_pat (AsPat id p) = unLoc (simplify_lpat p) +simplify_pat (SigPatOut p _) = unLoc (simplify_lpat p) -- I'm not sure this is right -simplify_pat (ParPat p) = unLoc (simplify_lpat p) -simplify_pat (LazyPat p) = unLoc (simplify_lpat p) -simplify_pat (AsPat id p) = unLoc (simplify_lpat p) -simplify_pat (SigPatOut p ty fn) = unLoc (simplify_lpat p) -- I'm not sure this is right - -simplify_pat (ConPatOut id ps ty tvs dicts) = ConPatOut id (simplify_con id ps) ty tvs dicts +simplify_pat (ConPatOut id tvs dicts binds ps ty) + = ConPatOut id tvs dicts binds (simplify_con id ps) ty simplify_pat (ListPat ps ty) = unLoc $ foldr (\ x y -> mkPrefixConPat consDataCon [x,y] list_ty) @@ -607,16 +597,14 @@ simplify_pat (ListPat ps ty) = -- arrays with the existing machinery for constructor pattern -- simplify_pat (PArrPat ps ty) - = ConPatOut (parrFakeCon arity) - (PrefixCon (map simplify_lpat ps)) - (mkPArrTy ty) [] [] - where - arity = length ps + = mk_simple_con_pat (parrFakeCon (length ps)) + (PrefixCon (map simplify_lpat ps)) + (mkPArrTy ty) simplify_pat (TuplePat ps boxity) - = ConPatOut (tupleCon boxity arity) - (PrefixCon (map simplify_lpat ps)) - (mkTupleTy boxity arity (map hsPatType ps)) [] [] + = mk_simple_con_pat (tupleCon boxity arity) + (PrefixCon (map simplify_lpat ps)) + (mkTupleTy boxity arity (map hsPatType ps)) where arity = length ps @@ -625,12 +613,10 @@ simplify_pat pat@(LitPat lit) = unLoc (tidyLitPat lit (noLoc pat)) -- unpack string patterns fully, so we can see when they overlap with -- each other, or even explicit lists of Chars. simplify_pat pat@(NPatOut (HsString s) _ _) = - foldr (\c pat -> ConPatOut consDataCon (PrefixCon [mk_char_lit c,noLoc pat]) stringTy [] []) - (ConPatOut nilDataCon (PrefixCon []) stringTy [] []) (unpackFS s) + foldr (\c pat -> mk_simple_con_pat consDataCon (PrefixCon [mk_char_lit c,noLoc pat]) stringTy) + (mk_simple_con_pat nilDataCon (PrefixCon []) stringTy) (unpackFS s) where - mk_char_lit c = noLoc $ - ConPatOut charDataCon (PrefixCon [nlLitPat (HsCharPrim c)]) - charTy [] [] + mk_char_lit c = noLoc (mk_simple_con_pat charDataCon (PrefixCon [nlLitPat (HsCharPrim c)]) charTy) simplify_pat pat@(NPatOut lit lit_ty hsexpr) = unLoc (tidyNPat lit lit_ty (noLoc pat)) @@ -646,6 +632,8 @@ simplify_pat (DictPat dicts methods) num_of_d_and_ms = length dicts + length methods dict_and_method_pats = map VarPat (dicts ++ methods) +mk_simple_con_pat con args ty = ConPatOut con [] [] emptyLHsBinds args ty + ----------------- simplify_con con (PrefixCon ps) = PrefixCon (map simplify_lpat ps) simplify_con con (InfixCon p1 p2) = PrefixCon [simplify_lpat p1, simplify_lpat p2] @@ -655,8 +643,7 @@ simplify_con con (RecCon fs) | otherwise = PrefixCon (map (simplify_lpat.snd) all_pats) where -- pad out all the missing fields with WildPats. - field_pats = map (\ f -> (getName f, nlWildPat)) - (dataConFieldLabels con) + field_pats = map (\ f -> (f, nlWildPat)) (dataConFieldLabels con) all_pats = foldr (\ (id,p) acc -> insertNm (getName (unLoc id)) p acc) field_pats fs diff --git a/ghc/compiler/deSugar/Desugar.lhs b/ghc/compiler/deSugar/Desugar.lhs index 84b7216edd..02c475fd6b 100644 --- a/ghc/compiler/deSugar/Desugar.lhs +++ b/ghc/compiler/deSugar/Desugar.lhs @@ -10,8 +10,7 @@ module Desugar ( deSugar, deSugarExpr ) where import CmdLineOpts ( DynFlag(..), dopt, opt_SccProfilingOn ) import HscTypes ( ModGuts(..), ModGuts, HscEnv(..), GhciMode(..), - Dependencies(..), TypeEnv, - unQualInScope, availsToNameSet ) + Dependencies(..), TypeEnv, unQualInScope ) import HsSyn ( RuleDecl(..), RuleBndr(..), HsExpr(..), LHsExpr, HsBindGroup(..), LRuleDecl, HsBind(..) ) import TcRnTypes ( TcGblEnv(..), ImportAvails(..) ) @@ -20,14 +19,14 @@ import Id ( Id, setIdLocalExported, idName ) import Name ( Name, isExternalName ) import CoreSyn import PprCore ( pprIdRules, pprCoreExpr ) -import Subst ( substExpr, mkSubst, mkInScopeSet ) +import Subst ( SubstResult(..), substExpr, mkSubst, extendIdSubstList ) import DsMonad import DsExpr ( dsLExpr ) import DsBinds ( dsHsBinds, AutoScc(..) ) import DsForeign ( dsForeigns ) import DsExpr () -- Forces DsExpr to be compiled; DsBinds only -- depends on DsExpr.hi-boot. -import Module ( Module, moduleEnvElts, emptyModuleEnv ) +import Module ( Module, moduleEnvElts ) import Id ( Id ) import RdrName ( GlobalRdrEnv ) import NameSet @@ -277,12 +276,10 @@ ds_lhs all_vars lhs -- Substitute the dict bindings eagerly, -- and take the body apart into a (f args) form let - subst_env = mkSubstEnv [id | (id,rhs) <- dict_binds'] - [ContEx subst_env rhs | (id,rhs) <- dict_binds'] + subst = extendIdSubstList (mkSubst all_vars) pairs + pairs = [(id, ContEx subst rhs) | (id,rhs) <- dict_binds'] -- Note recursion here... substitution won't terminate -- if there is genuine recursion... which there isn't - - subst = mkSubst all_vars subst_env body'' = substExpr subst body' in diff --git a/ghc/compiler/deSugar/DsArrows.lhs b/ghc/compiler/deSugar/DsArrows.lhs index 8e9ce4cc32..30531eaf30 100644 --- a/ghc/compiler/deSugar/DsArrows.lhs +++ b/ghc/compiler/deSugar/DsArrows.lhs @@ -10,7 +10,7 @@ module DsArrows ( dsProcExpr ) where import Match ( matchSimply ) import DsUtils ( mkErrorAppDs, - mkCoreTupTy, mkCoreTup, selectMatchVarL, + mkCoreTupTy, mkCoreTup, selectSimpleMatchVarL, mkTupleCase, mkBigCoreTup, mkTupleType, mkTupleExpr, mkTupleSelector, dsReboundNames, lookupReboundName ) @@ -26,8 +26,8 @@ import TcHsSyn ( hsPatType ) import {-# SOURCE #-} DsExpr ( dsExpr, dsLExpr, dsLet ) -import TcType ( Type, tcSplitAppTy ) -import Type ( mkTyConApp ) +import TcType ( Type, tcSplitAppTy, mkFunTy ) +import Type ( mkTyConApp, funArgTy ) import CoreSyn import CoreFVs ( exprFreeVars ) import CoreUtils ( mkIfThenElse, bindNonRec, exprType ) @@ -44,7 +44,7 @@ import PrelNames ( eitherTyConName, leftDataConName, rightDataConName, import Util ( mapAccumL ) import Outputable -import HsPat ( collectPatBinders, collectPatsBinders ) +import HsUtils ( collectPatBinders, collectPatsBinders ) import VarSet ( IdSet, mkVarSet, varSetElems, intersectVarSet, minusVarSet, extendVarSetList, unionVarSet, unionVarSets, elemVarSet ) @@ -139,7 +139,8 @@ coreCaseTuple uniqs scrut_var vars body coreCasePair :: Id -> Id -> Id -> CoreExpr -> CoreExpr coreCasePair scrut_var var1 var2 body - = Case (Var scrut_var) scrut_var +-- gaw 2004 + = Case (Var scrut_var) scrut_var (exprType body) [(DataAlt (tupleCon Boxed 2), [var1, var2], body)] \end{code} @@ -258,7 +259,7 @@ dsProcExpr pat (L _ (HsCmdTop cmd [] cmd_ty ids)) env_ty = mkTupleType env_ids in mkFailExpr ProcExpr env_ty `thenDs` \ fail_expr -> - selectMatchVarL pat `thenDs` \ var -> + selectSimpleMatchVarL pat `thenDs` \ var -> matchSimply (Var var) ProcExpr pat (mkTupleExpr env_ids) fail_expr `thenDs` \ match_code -> let @@ -388,7 +389,7 @@ dsCmd ids local_vars env_ids stack res_ty (HsApp cmd arg) -- ---> arr (\ ((((xs), p1), ... pk)*ts) -> ((ys)*ts)) >>> c dsCmd ids local_vars env_ids stack res_ty - (HsLam (L _ (Match pats _ (GRHSs [L _ (GRHS [L _ (ResultStmt body)])] _ _cmd_ty)))) + (HsLam (MatchGroup [L _ (Match pats _ (GRHSs [L _ (GRHS [L _ (ResultStmt body)])] _ ))] _)) = let pat_vars = mkVarSet (collectPatsBinders pats) local_vars' = local_vars `unionVarSet` pat_vars @@ -489,7 +490,7 @@ case bodies, containing the following fields: bodies with |||. \begin{code} -dsCmd ids local_vars env_ids stack res_ty (HsCase exp matches) +dsCmd ids local_vars env_ids stack res_ty (HsCase exp (MatchGroup matches match_ty)) = dsLExpr exp `thenDs` \ core_exp -> mappM newSysLocalDs stack `thenDs` \ stack_ids -> @@ -535,8 +536,13 @@ dsCmd ids local_vars env_ids stack res_ty (HsCase exp matches) (_, matches') = mapAccumL (replaceLeavesMatch res_ty) leaves' matches in_ty = envStackType env_ids stack fvs_exp = exprFreeVars core_exp `intersectVarSet` local_vars + + pat_ty = funArgTy match_ty + match_ty' = mkFunTy pat_ty sum_ty + -- Note that we replace the HsCase result type by sum_ty, + -- which is the type of matches' in - dsExpr (HsCase exp matches') `thenDs` \ core_body -> + dsExpr (HsCase exp (MatchGroup matches' match_ty')) `thenDs` \ core_body -> matchEnvStack env_ids stack_ids core_body `thenDs` \ core_matches -> returnDs(do_map_arrow ids in_ty sum_ty res_ty core_matches core_choices, @@ -755,7 +761,6 @@ dsCmdStmt ids local_vars env_ids out_ids (BindStmt pat cmd) -- projection function -- \ (p, (xs2)) -> (zs) - selectMatchVarL pat `thenDs` \ pat_id -> newSysLocalDs env_ty2 `thenDs` \ env_id -> newUniqueSupply `thenDs` \ uniqs -> let @@ -764,6 +769,7 @@ dsCmdStmt ids local_vars env_ids out_ids (BindStmt pat cmd) body_expr = coreCaseTuple uniqs env_id env_ids2 (mkTupleExpr out_ids) in mkFailExpr (StmtCtxt DoExpr) out_ty `thenDs` \ fail_expr -> + selectSimpleMatchVarL pat `thenDs` \ pat_id -> matchSimply (Var pat_id) (StmtCtxt DoExpr) pat body_expr fail_expr `thenDs` \ match_code -> newSysLocalDs after_c_ty `thenDs` \ pair_id -> @@ -999,7 +1005,7 @@ List of leaf expressions, with set of variables bound in each \begin{code} leavesMatch :: LMatch Id -> [(LHsExpr Id, IdSet)] -leavesMatch (L _ (Match pats _ (GRHSs grhss binds _ty))) +leavesMatch (L _ (Match pats _ (GRHSs grhss binds))) = let defined_vars = mkVarSet (collectPatsBinders pats) `unionVarSet` @@ -1021,11 +1027,11 @@ replaceLeavesMatch -> LMatch Id -- the matches of a case command -> ([LHsExpr Id],-- remaining leaf expressions LMatch Id) -- updated match -replaceLeavesMatch res_ty leaves (L loc (Match pat mt (GRHSs grhss binds _ty))) +replaceLeavesMatch res_ty leaves (L loc (Match pat mt (GRHSs grhss binds))) = let (leaves', grhss') = mapAccumL replaceLeavesGRHS leaves grhss in - (leaves', L loc (Match pat mt (GRHSs grhss' binds res_ty))) + (leaves', L loc (Match pat mt (GRHSs grhss' binds))) replaceLeavesGRHS :: [LHsExpr Id] -- replacement leaf expressions of that type diff --git a/ghc/compiler/deSugar/DsBinds.lhs b/ghc/compiler/deSugar/DsBinds.lhs index 0d5cb7ec46..369660a939 100644 --- a/ghc/compiler/deSugar/DsBinds.lhs +++ b/ghc/compiler/deSugar/DsBinds.lhs @@ -8,12 +8,14 @@ in that the @Rec@/@NonRec@/etc structure is thrown away (whereas at lower levels it is preserved with @let@/@letrec@s). \begin{code} -module DsBinds ( dsHsBinds, AutoScc(..) ) where +module DsBinds ( dsHsBinds, dsHsNestedBinds, AutoScc(..) ) where #include "HsVersions.h" import {-# SOURCE #-} DsExpr( dsLExpr ) +import {-# SOURCE #-} Match( matchWrapper ) + import DsMonad import DsGRHSs ( dsGuarded ) import DsUtils @@ -21,21 +23,18 @@ import DsUtils import HsSyn -- lots of things import CoreSyn -- lots of things import CoreUtils ( exprType, mkInlineMe, mkSCC ) -import Match ( matchWrapper ) import CmdLineOpts ( opt_AutoSccsOnAllToplevs, opt_AutoSccsOnExportedToplevs ) import CostCentre ( mkAutoCC, IsCafCC(..) ) import Id ( idType, idName, isExportedId, isSpecPragmaId, Id ) import NameSet import VarSet -import TcType ( mkTyVarTy ) -import Subst ( substTyWith ) +import Type ( mkTyVarTy, substTyWith ) import TysWiredIn ( voidTy ) import Outputable import SrcLoc ( Located(..) ) import Maybe ( isJust ) -import Bag ( Bag, bagToList ) - +import Bag ( bagToList ) import Monad ( foldM ) \end{code} @@ -46,13 +45,16 @@ import Monad ( foldM ) %************************************************************************ \begin{code} +dsHsNestedBinds :: LHsBinds Id -> DsM [(Id,CoreExpr)] +dsHsNestedBinds binds = dsHsBinds NoSccs binds [] + dsHsBinds :: AutoScc -- scc annotation policy (see below) - -> Bag (LHsBind Id) + -> LHsBinds Id -> [(Id,CoreExpr)] -- Put this on the end (avoid quadratic append) -> DsM [(Id,CoreExpr)] -- Result -dsHsBinds auto_scc binds rest = - foldM (dsLHsBind auto_scc) rest (bagToList binds) +dsHsBinds auto_scc binds rest + = foldM (dsLHsBind auto_scc) rest (bagToList binds) dsLHsBind :: AutoScc -> [(Id,CoreExpr)] -- Put this on the end (avoid quadratic append) @@ -86,12 +88,12 @@ dsHsBind auto_scc rest (VarBind var expr) returnDs ((var, core_expr'') : rest) dsHsBind auto_scc rest (FunBind (L _ fun) _ matches) - = matchWrapper (FunRhs (idName fun)) matches `thenDs` \ (args, body) -> - addAutoScc auto_scc (fun, mkLams args body) `thenDs` \ pair -> + = matchWrapper (FunRhs (idName fun)) matches `thenDs` \ (args, body) -> + addAutoScc auto_scc (fun, mkLams args body) `thenDs` \ pair -> returnDs (pair : rest) -dsHsBind auto_scc rest (PatBind pat grhss) - = dsGuarded grhss `thenDs` \ body_expr -> +dsHsBind auto_scc rest (PatBind pat grhss ty) + = dsGuarded grhss ty `thenDs` \ body_expr -> mkSelectorBinds pat body_expr `thenDs` \ sel_binds -> mappM (addAutoScc auto_scc) sel_binds `thenDs` \ sel_binds -> returnDs (sel_binds ++ rest) diff --git a/ghc/compiler/deSugar/DsCCall.lhs b/ghc/compiler/deSugar/DsCCall.lhs index 57bace2000..a2af48e577 100644 --- a/ghc/compiler/deSugar/DsCCall.lhs +++ b/ghc/compiler/deSugar/DsCCall.lhs @@ -19,7 +19,7 @@ import CoreSyn import DsMonad -import CoreUtils ( exprType, mkCoerce2 ) +import CoreUtils ( exprType, coreAltType, mkCoerce2 ) import Id ( Id, mkWildId ) import MkId ( mkFCallId, realWorldPrimId, mkPrimOpId ) import Maybes ( maybeToBool ) @@ -47,7 +47,7 @@ import TysWiredIn ( unitDataConId, unboxedSingletonTyCon, unboxedPairTyCon, trueDataCon, falseDataCon, trueDataConId, falseDataConId, - listTyCon, charTyCon, + listTyCon, charTyCon, boolTy, tupleTyCon, tupleCon ) import BasicTypes ( Boxity(..) ) @@ -169,10 +169,13 @@ unboxArg arg tc `hasKey` boolTyConKey = newSysLocalDs intPrimTy `thenDs` \ prim_arg -> returnDs (Var prim_arg, - \ body -> Case (Case arg (mkWildId arg_ty) +-- gaw 2004 + \ body -> Case (Case arg (mkWildId arg_ty) intPrimTy [(DataAlt falseDataCon,[],mkIntLit 0), (DataAlt trueDataCon, [],mkIntLit 1)]) - prim_arg + prim_arg +-- gaw 2004 + (exprType body) [(DEFAULT,[],body)]) -- Data types with a single constructor, which has a single, primitive-typed arg @@ -183,7 +186,8 @@ unboxArg arg newSysLocalDs arg_ty `thenDs` \ case_bndr -> newSysLocalDs data_con_arg_ty1 `thenDs` \ prim_arg -> returnDs (Var prim_arg, - \ body -> Case arg case_bndr [(DataAlt data_con,[prim_arg],body)] +-- gaw 2004 + \ body -> Case arg case_bndr (exprType body) [(DataAlt data_con,[prim_arg],body)] ) -- Byte-arrays, both mutable and otherwise; hack warning @@ -199,7 +203,9 @@ unboxArg arg = newSysLocalDs arg_ty `thenDs` \ case_bndr -> newSysLocalsDs data_con_arg_tys `thenDs` \ vars@[l_var, r_var, arr_cts_var] -> returnDs (Var arr_cts_var, - \ body -> Case arg case_bndr [(DataAlt data_con,vars,body)] +-- gaw 2004 + \ body -> Case arg case_bndr (exprType body) [(DataAlt data_con,vars,body)] + ) | Just (tc, [arg_ty]) <- splitTyConApp_maybe arg_ty, @@ -303,6 +309,8 @@ boxResult arg_ids augment mbTopCon result_ty Lam state_id $ Case (App the_call (Var state_id)) (mkWildId ccall_res_ty) +-- gaw 2004 + (coreAltType the_alt) [the_alt] ] in @@ -319,6 +327,8 @@ boxResult arg_ids augment mbTopCon result_ty let wrap = \ the_call -> Case (App the_call (Var realWorldPrimId)) (mkWildId ccall_res_ty) +-- gaw 2004 + (coreAltType the_alt) [the_alt] in returnDs (realWorldStatePrimTy `mkFunTy` ccall_res_ty, wrap) @@ -387,6 +397,8 @@ resultWrapper result_ty | Just (tc,_) <- maybe_tc_app, tc `hasKey` boolTyConKey = returnDs (Just intPrimTy, \e -> Case e (mkWildId intPrimTy) +-- gaw 2004 + boolTy [(DEFAULT ,[],Var trueDataConId ), (LitAlt (mkMachInt 0),[],Var falseDataConId)]) diff --git a/ghc/compiler/deSugar/DsExpr.lhs b/ghc/compiler/deSugar/DsExpr.lhs index 42f5adde62..03c3710b47 100644 --- a/ghc/compiler/deSugar/DsExpr.lhs +++ b/ghc/compiler/deSugar/DsExpr.lhs @@ -11,11 +11,11 @@ module DsExpr ( dsExpr, dsLExpr, dsLet, dsLit ) where import Match ( matchWrapper, matchSimply ) import MatchLit ( dsLit ) -import DsBinds ( dsHsBinds, AutoScc(..) ) +import DsBinds ( dsHsNestedBinds ) import DsGRHSs ( dsGuarded ) import DsListComp ( dsListComp, dsPArrComp ) -import DsUtils ( mkErrorAppDs, mkStringLit, mkConsExpr, mkNilExpr, - mkCoreTupTy, selectMatchVarL, +import DsUtils ( mkErrorAppDs, mkStringExpr, mkConsExpr, mkNilExpr, + mkCoreTupTy, selectSimpleMatchVarL, dsReboundNames, lookupReboundName ) import DsArrows ( dsProcExpr ) import DsMonad @@ -33,21 +33,19 @@ import TcHsSyn ( hsPatType ) -- So WATCH OUT; check each use of split*Ty functions. -- Sigh. This is a pain. -import TcType ( tcSplitAppTy, tcSplitFunTys, tcTyConAppArgs, - tcSplitTyConApp, isUnLiftedType, Type, - mkAppTy ) -import Type ( splitFunTys ) +import TcType ( tcSplitAppTy, tcSplitFunTys, tcTyConAppTyCon, tcTyConAppArgs, + tcTyConAppArgs, isUnLiftedType, Type, mkAppTy ) +import Type ( mkFunTys, funArgTy, splitFunTys, isUnboxedTupleType, mkFunTy ) import CoreSyn import CoreUtils ( exprType, mkIfThenElse, bindNonRec ) -import FieldLabel ( FieldLabel, fieldLabelTyCon ) import CostCentre ( mkUserCC ) -import Id ( Id, idType, idName, recordSelectorFieldLabel ) +import Id ( Id, idType, idName ) import PrelInfo ( rEC_CON_ERROR_ID, iRREFUT_PAT_ERROR_ID ) import DataCon ( DataCon, dataConWrapId, dataConFieldLabels, dataConInstOrigArgTys ) -import DataCon ( isExistentialDataCon ) +import DataCon ( isVanillaDataCon ) import Name ( Name ) -import TyCon ( tyConDataCons ) +import TyCon ( FieldLabel, tyConDataCons ) import TysWiredIn ( tupleCon ) import BasicTypes ( RecFlag(..), Boxity(..), ipNameName ) import PrelNames ( toPName, @@ -115,14 +113,14 @@ dsBindGroup body bind@(HsBindGroup hsbinds sigs is_rec) in case bagToList binds of [L loc (FunBind (L _ fun) _ matches)] - -> putSrcSpanDs loc $ - matchWrapper (FunRhs (idName fun)) matches `thenDs` \ (args, rhs) -> + -> putSrcSpanDs loc $ + matchWrapper (FunRhs (idName fun)) matches `thenDs` \ (args, rhs) -> ASSERT( null args ) -- Functions aren't lifted returnDs (bindNonRec fun rhs body_w_exports) - [L loc (PatBind pat grhss)] + [L loc (PatBind pat grhss ty)] -> putSrcSpanDs loc $ - dsGuarded grhss `thenDs` \ rhs -> + dsGuarded grhss ty `thenDs` \ rhs -> mk_error_app pat `thenDs` \ error_expr -> matchSimply rhs PatBindRhs pat body_w_exports error_expr @@ -130,7 +128,7 @@ dsBindGroup body bind@(HsBindGroup hsbinds sigs is_rec) -- Ordinary case for bindings dsBindGroup body (HsBindGroup binds sigs is_rec) - = dsHsBinds NoSccs binds [] `thenDs` \ prs -> + = dsHsNestedBinds binds `thenDs` \ prs -> returnDs (Let (Rec prs) body) -- Use a Rec regardless of is_rec. -- Why? Because it allows the binds to be all @@ -164,7 +162,7 @@ dsExpr (HsLit lit) = dsLit lit -- HsOverLit has been gotten rid of by the type checker dsExpr expr@(HsLam a_Match) - = matchWrapper LambdaExpr [a_Match] `thenDs` \ (binders, matching_code) -> + = matchWrapper LambdaExpr a_Match `thenDs` \ (binders, matching_code) -> returnDs (mkLams binders matching_code) dsExpr expr@(HsApp fun arg) @@ -244,23 +242,19 @@ dsExpr (HsCoreAnn fs expr) = dsLExpr expr `thenDs` \ core_expr -> returnDs (Note (CoreNote $ unpackFS fs) core_expr) --- special case to handle unboxed tuple patterns. - -dsExpr (HsCase discrim matches) - | all ubx_tuple_match matches +-- Special case to handle unboxed tuple patterns; they can't appear nested +dsExpr (HsCase discrim matches@(MatchGroup _ ty)) + | isUnboxedTupleType (funArgTy ty) = dsLExpr discrim `thenDs` \ core_discrim -> matchWrapper CaseAlt matches `thenDs` \ ([discrim_var], matching_code) -> case matching_code of - Case (Var x) bndr alts | x == discrim_var -> - returnDs (Case core_discrim bndr alts) + Case (Var x) bndr ty alts | x == discrim_var -> + returnDs (Case core_discrim bndr ty alts) _ -> panic ("dsLExpr: tuple pattern:\n" ++ showSDoc (ppr matching_code)) - where - ubx_tuple_match (L _ (Match [L _ (TuplePat _ Unboxed)] _ _)) = True - ubx_tuple_match _ = False dsExpr (HsCase discrim matches) = dsLExpr discrim `thenDs` \ core_discrim -> - matchWrapper CaseAlt matches `thenDs` \ ([discrim_var], matching_code) -> + matchWrapper CaseAlt matches `thenDs` \ ([discrim_var], matching_code) -> returnDs (bindNonRec discrim_var core_discrim matching_code) dsExpr (HsLet binds body) @@ -274,7 +268,7 @@ dsExpr (HsDo ListComp stmts _ result_ty) = -- Special case for list comprehensions dsListComp stmts elt_ty where - (_, [elt_ty]) = tcSplitTyConApp result_ty + [elt_ty] = tcTyConAppArgs result_ty dsExpr (HsDo do_or_lc stmts ids result_ty) | isDoExpr do_or_lc @@ -284,7 +278,7 @@ dsExpr (HsDo PArrComp stmts _ result_ty) = -- Special case for array comprehensions dsPArrComp (map unLoc stmts) elt_ty where - (_, [elt_ty]) = tcSplitTyConApp result_ty + [elt_ty] = tcTyConAppArgs result_ty dsExpr (HsIf guard_expr then_expr else_expr) = dsLExpr guard_expr `thenDs` \ core_guard -> @@ -412,9 +406,8 @@ dsExpr (RecordConOut data_con con_expr rbinds) -- A newtype in the corner should be opaque; -- hence TcType.tcSplitFunTys - mk_arg (arg_ty, lbl) - = case [rhs | (L _ sel_id, rhs) <- rbinds, - lbl == recordSelectorFieldLabel sel_id] of + mk_arg (arg_ty, lbl) -- Selector id has the field label as its name + = case [rhs | (L _ sel_id, rhs) <- rbinds, lbl == idName sel_id] of (rhs:rhss) -> ASSERT( null rhss ) dsLExpr rhs [] -> mkErrorAppDs rEC_CON_ERROR_ID arg_ty (showSDoc (ppr lbl)) @@ -465,16 +458,17 @@ dsExpr expr@(RecordUpdOut record_expr record_in_ty record_out_ty rbinds) let in_inst_tys = tcTyConAppArgs record_in_ty -- Newtype opaque out_inst_tys = tcTyConAppArgs record_out_ty -- Newtype opaque + in_out_ty = mkFunTy record_in_ty record_out_ty mk_val_arg field old_arg_id - = case [rhs | (L _ sel_id, rhs) <- rbinds, - field == recordSelectorFieldLabel sel_id] of + = case [rhs | (L _ sel_id, rhs) <- rbinds, field == idName sel_id] of (rhs:rest) -> ASSERT(null rest) rhs [] -> nlHsVar old_arg_id mk_alt con = newSysLocalsDs (dataConInstOrigArgTys con in_inst_tys) `thenDs` \ arg_ids -> -- This call to dataConArgTys won't work for existentials + -- but existentials don't have record types anyway let val_args = zipWithEqual "dsExpr:RecordUpd" mk_val_arg (dataConFieldLabels con) arg_ids @@ -483,34 +477,33 @@ dsExpr expr@(RecordUpdOut record_expr record_in_ty record_out_ty rbinds) out_inst_tys) val_args in - returnDs (mkSimpleMatch [noLoc $ ConPatOut con (PrefixCon (map nlVarPat arg_ids)) record_in_ty [] []] - rhs - record_out_ty) + returnDs (mkSimpleMatch [noLoc $ ConPatOut con [] [] emptyLHsBinds + (PrefixCon (map nlVarPat arg_ids)) record_in_ty] + rhs) in -- Record stuff doesn't work for existentials -- The type checker checks for this, but we need -- worry only about the constructors that are to be updated - ASSERT2( all (not . isExistentialDataCon) cons_to_upd, ppr expr ) + ASSERT2( all isVanillaDataCon cons_to_upd, ppr expr ) -- It's important to generate the match with matchWrapper, -- and the right hand sides with applications of the wrapper Id -- so that everything works when we are doing fancy unboxing on the -- constructor aguments. - mappM mk_alt cons_to_upd `thenDs` \ alts -> - matchWrapper RecUpd alts `thenDs` \ ([discrim_var], matching_code) -> + mappM mk_alt cons_to_upd `thenDs` \ alts -> + matchWrapper RecUpd (MatchGroup alts in_out_ty) `thenDs` \ ([discrim_var], matching_code) -> returnDs (bindNonRec discrim_var record_expr' matching_code) where updated_fields :: [FieldLabel] - updated_fields = [ recordSelectorFieldLabel sel_id - | (L _ sel_id,_) <- rbinds] + updated_fields = [ idName sel_id | (L _ sel_id,_) <- rbinds] - -- Get the type constructor from the first field label, + -- Get the type constructor from the record_in_ty -- so that we are sure it'll have all its DataCons -- (In GHCI, it's possible that some TyCons may not have all -- their constructors, in a module-loop situation.) - tycon = fieldLabelTyCon (head updated_fields) + tycon = tcTyConAppTyCon record_in_ty data_cons = tyConDataCons tycon cons_to_upd = filter has_all_fields data_cons @@ -608,14 +601,14 @@ dsDo do_or_lc stmts ids result_ty go (BindStmt pat expr : stmts) = go stmts `thenDs` \ body -> dsLExpr expr `thenDs` \ rhs -> - mkStringLit (mk_msg (getLoc pat)) `thenDs` \ core_msg -> + mkStringExpr (mk_msg (getLoc pat)) `thenDs` \ core_msg -> let -- In a do expression, pattern-match failure just calls -- the monadic 'fail' rather than throwing an exception fail_expr = mkApps fail_id [Type b_ty, core_msg] a_ty = hsPatType pat in - selectMatchVarL pat `thenDs` \ var -> + selectSimpleMatchVarL pat `thenDs` \ var -> matchSimply (Var var) (StmtCtxt do_or_lc) pat body fail_expr `thenDs` \ match_code -> returnDs (mkApps bind_id [Type a_ty, Type b_ty, rhs, Lam var match_code]) @@ -655,18 +648,20 @@ dsRecStmt m_ty ds_meths stmts later_vars rec_vars rec_rets one_var = null rest mfix_app = nlHsApp (noLoc $ TyApp (nlHsVar mfix_id) [tup_ty]) mfix_arg - mfix_arg = noLoc $ HsLam (mkSimpleMatch [tup_pat] body tup_ty) + mfix_arg = noLoc $ HsLam (MatchGroup [mkSimpleMatch [tup_pat] body] + (mkFunTy tup_ty body_ty)) tup_expr | one_var = ret1 | otherwise = noLoc $ ExplicitTuple rets Boxed - tup_ty = mkCoreTupTy (map idType vars) - -- Deals with singleton case + var_tys = map idType vars + tup_ty = mkCoreTupTy var_tys -- Deals with singleton case tup_pat | one_var = nlVarPat var1 | otherwise = noLoc $ LazyPat (noLoc $ TuplePat (map nlVarPat vars) Boxed) body = noLoc $ HsDo DoExpr (stmts ++ [return_stmt]) [(n, HsVar id) | (n,id) <- ds_meths] -- A bit of a hack - (mkAppTy m_ty tup_ty) + body_ty + body_ty = mkAppTy m_ty tup_ty Var return_id = lookupReboundName ds_meths returnMName Var mfix_id = lookupReboundName ds_meths mfixName diff --git a/ghc/compiler/deSugar/DsGRHSs.lhs b/ghc/compiler/deSugar/DsGRHSs.lhs index b36632699d..664e2ebdc9 100644 --- a/ghc/compiler/deSugar/DsGRHSs.lhs +++ b/ghc/compiler/deSugar/DsGRHSs.lhs @@ -14,8 +14,8 @@ import {-# SOURCE #-} Match ( matchSinglePat ) import HsSyn ( Stmt(..), HsExpr(..), GRHSs(..), GRHS(..), HsMatchContext(..), Pat(..) ) import CoreSyn ( CoreExpr ) -import Type ( Type ) import Var ( Id ) +import Type ( Type ) import DsMonad import DsUtils @@ -39,11 +39,11 @@ producing an expression with a runtime error in the corner if necessary. The type argument gives the type of the @ei@. \begin{code} -dsGuarded :: GRHSs Id -> DsM CoreExpr +dsGuarded :: GRHSs Id -> Type -> DsM CoreExpr -dsGuarded grhss - = dsGRHSs PatBindRhs [] grhss `thenDs` \ (err_ty, match_result) -> - mkErrorAppDs nON_EXHAUSTIVE_GUARDS_ERROR_ID err_ty "" `thenDs` \ error_expr -> +dsGuarded grhss rhs_ty + = dsGRHSs PatBindRhs [] grhss rhs_ty `thenDs` \ match_result -> + mkErrorAppDs nON_EXHAUSTIVE_GUARDS_ERROR_ID rhs_ty "" `thenDs` \ error_expr -> extractMatchResult match_result error_expr \end{code} @@ -52,19 +52,20 @@ In contrast, @dsGRHSs@ produces a @MatchResult@. \begin{code} dsGRHSs :: HsMatchContext Name -> [Pat Id] -- These are to build a MatchContext from -> GRHSs Id -- Guarded RHSs - -> DsM (Type, MatchResult) + -> Type -- Type of RHS + -> DsM MatchResult -dsGRHSs kind pats (GRHSs grhss binds ty) - = mappM (dsGRHS kind pats) grhss `thenDs` \ match_results -> +dsGRHSs kind pats (GRHSs grhss binds) rhs_ty + = mappM (dsGRHS kind pats rhs_ty) grhss `thenDs` \ match_results -> let match_result1 = foldr1 combineMatchResults match_results match_result2 = adjustMatchResultDs (dsLet binds) match_result1 -- NB: nested dsLet inside matchResult in - returnDs (ty, match_result2) + returnDs match_result2 -dsGRHS kind pats (L loc (GRHS guard)) - = matchGuard (map unLoc guard) (DsMatchContext kind pats loc) +dsGRHS kind pats rhs_ty (L loc (GRHS guard)) + = matchGuard (map unLoc guard) (DsMatchContext kind pats loc) rhs_ty \end{code} @@ -76,39 +77,43 @@ dsGRHS kind pats (L loc (GRHS guard)) \begin{code} matchGuard :: [Stmt Id] -- Guard - -> DsMatchContext -- Context + -> DsMatchContext -- Context + -> Type -- Type of RHS of guard -> DsM MatchResult -- See comments with HsExpr.Stmt re what an ExprStmt means -- Here we must be in a guard context (not do-expression, nor list-comp) -matchGuard [ResultStmt expr] ctx - = dsLExpr expr `thenDs` \ core_expr -> - returnDs (cantFailMatchResult core_expr) +matchGuard [ResultStmt expr] ctx rhs_ty + = do { core_expr <- dsLExpr expr + ; return (cantFailMatchResult core_expr) } -- ExprStmts must be guards -- Turn an "otherwise" guard is a no-op -matchGuard (ExprStmt (L _ (HsVar v)) _ : stmts) ctx +matchGuard (ExprStmt (L _ (HsVar v)) _ : stmts) ctx rhs_ty | v `hasKey` otherwiseIdKey || v `hasKey` getUnique trueDataConId -- trueDataConId doesn't have the same -- unique as trueDataCon - = matchGuard stmts ctx + = matchGuard stmts ctx rhs_ty -matchGuard (ExprStmt expr _ : stmts) ctx - = matchGuard stmts ctx `thenDs` \ match_result -> +matchGuard (ExprStmt expr _ : stmts) ctx rhs_ty + = matchGuard stmts ctx rhs_ty `thenDs` \ match_result -> dsLExpr expr `thenDs` \ pred_expr -> returnDs (mkGuardedMatchResult pred_expr match_result) -matchGuard (LetStmt binds : stmts) ctx - = matchGuard stmts ctx `thenDs` \ match_result -> +matchGuard (LetStmt binds : stmts) ctx rhs_ty + = matchGuard stmts ctx rhs_ty `thenDs` \ match_result -> returnDs (adjustMatchResultDs (dsLet binds) match_result) -- NB the dsLet occurs inside the match_result - -matchGuard (BindStmt pat rhs : stmts) ctx - = matchGuard stmts ctx `thenDs` \ match_result -> - dsLExpr rhs `thenDs` \ core_rhs -> - matchSinglePat core_rhs ctx pat match_result + -- Reason: dsLet takes the body expression as its argument + -- so we can't desugar the bindings without the + -- body expression in hand + +matchGuard (BindStmt pat bind_rhs : stmts) ctx rhs_ty + = matchGuard stmts ctx rhs_ty `thenDs` \ match_result -> + dsLExpr bind_rhs `thenDs` \ core_rhs -> + matchSinglePat core_rhs ctx pat rhs_ty match_result \end{code} Should {\em fail} if @e@ returns @D@ diff --git a/ghc/compiler/deSugar/DsListComp.lhs b/ghc/compiler/deSugar/DsListComp.lhs index d6b00657d7..8491613e1d 100644 --- a/ghc/compiler/deSugar/DsListComp.lhs +++ b/ghc/compiler/deSugar/DsListComp.lhs @@ -212,8 +212,10 @@ deBindComp pat core_list1 quals core_list2 rest_expr core_fail `thenDs` \ core_match -> let rhs = Lam u1 $ - Case (Var u1) u1 [(DataAlt nilDataCon, [], core_list2), - (DataAlt consDataCon, [u2, u3], core_match)] +-- gaw 2004 + Case (Var u1) u1 res_ty + [(DataAlt nilDataCon, [], core_list2), + (DataAlt consDataCon, [u2, u3], core_match)] in returnDs (Let (Rec [(h, rhs)]) letrec_body) \end{code} @@ -242,13 +244,16 @@ mkZipBind elt_tys in returnDs (zip_fn, mkLams ass zip_body) where - list_tys = map mkListTy elt_tys - ret_elt_ty = mkCoreTupTy elt_tys - zip_fn_ty = mkFunTys list_tys (mkListTy ret_elt_ty) + list_tys = map mkListTy elt_tys + ret_elt_ty = mkCoreTupTy elt_tys + list_ret_ty = mkListTy ret_elt_ty + zip_fn_ty = mkFunTys list_tys list_ret_ty mk_case (as, a', as') rest - = Case (Var as) as [(DataAlt nilDataCon, [], mkNilExpr ret_elt_ty), - (DataAlt consDataCon, [a', as'], rest)] +-- gaw 2004 + = Case (Var as) as list_ret_ty + [(DataAlt nilDataCon, [], mkNilExpr ret_elt_ty), + (DataAlt consDataCon, [a', as'], rest)] -- Helper functions that makes an HsTuple only for non-1-sized tuples mk_hs_tuple_expr :: [Id] -> LHsExpr Id @@ -318,7 +323,7 @@ dfListComp c_id n_id (BindStmt pat list1 : quals) dfListComp c_id b quals `thenDs` \ core_rest -> -- build the pattern match - matchSimply (Var x) (StmtCtxt ListComp) + matchSimply (Var x) (StmtCtxt ListComp) pat core_rest (Var b) `thenDs` \ core_expr -> -- now build the outermost foldr, and return @@ -460,7 +465,7 @@ deLambda ty p e = let errTy = exprType ce errMsg = "DsListComp.deLambda: internal error!" in - mkErrorAppDs pAT_ERROR_ID errTy errMsg `thenDs` \cerr -> + mkErrorAppDs pAT_ERROR_ID errTy errMsg `thenDs` \cerr -> matchSimply (Var v) (StmtCtxt PArrComp) p ce cerr `thenDs` \res -> returnDs (mkLams [v] res, errTy) diff --git a/ghc/compiler/deSugar/DsMeta.hs b/ghc/compiler/deSugar/DsMeta.hs index 23117b0841..501b2d3a48 100644 --- a/ghc/compiler/deSugar/DsMeta.hs +++ b/ghc/compiler/deSugar/DsMeta.hs @@ -22,7 +22,7 @@ module DsMeta( dsBracket, import {-# SOURCE #-} DsExpr ( dsExpr ) import MatchLit ( dsLit ) -import DsUtils ( mkListExpr, mkStringLit, mkCoreTup, mkIntExpr ) +import DsUtils ( mkListExpr, mkStringExpr, mkCoreTup, mkIntExpr ) import DsMonad import qualified Language.Haskell.TH as TH @@ -280,10 +280,10 @@ repC (L loc con_decl) = do { dsWarn (loc, hang ds_msg 4 (ppr con_decl)) ; return (panic "DsMeta:repC") } where - +-- gaw 2004 FIX! Need a case for GadtDecl repBangTy :: LBangType Name -> DsM (Core (TH.StrictTypeQ)) -repBangTy (L _ (BangType str ty)) = do +repBangTy (L _ (HsBangTy str ty)) = do MkC s <- rep2 strName [] MkC t <- repLTy ty rep2 strictTypeName [s, t] @@ -462,7 +462,7 @@ repE (HsIPVar x) = panic "DsMeta.repE: Can't represent implicit parameters" -- HsOverlit can definitely occur repE (HsOverLit l) = do { a <- repOverloadedLiteral l; repLit a } repE (HsLit l) = do { a <- repLiteral l; repLit a } -repE (HsLam m) = repLambda m +repE (HsLam (MatchGroup [m] _)) = repLambda m repE (HsApp x y) = do {a <- repLE x; b <- repLE y; repApp a b} repE (OpApp e1 op fix e2) = @@ -477,9 +477,9 @@ repE (NegApp x nm) = do repE (HsPar x) = repLE x repE (SectionL x y) = do { a <- repLE x; b <- repLE y; repSectionL a b } repE (SectionR x y) = do { a <- repLE x; b <- repLE y; repSectionR a b } -repE (HsCase e ms) = do { arg <- repLE e - ; ms2 <- mapM repMatchTup ms - ; repCaseE arg (nonEmptyCoreList ms2) } +repE (HsCase e (MatchGroup ms _)) = do { arg <- repLE e + ; ms2 <- mapM repMatchTup ms + ; repCaseE arg (nonEmptyCoreList ms2) } repE (HsIf x y z) = do a <- repLE x b <- repLE y @@ -548,7 +548,7 @@ repE e = pprPanic "DsMeta.repE: Illegal expression form" (ppr e) -- Building representations of auxillary structures like Match, Clause, Stmt, repMatchTup :: LMatch Name -> DsM (Core TH.MatchQ) -repMatchTup (L _ (Match [p] ty (GRHSs guards wheres ty2))) = +repMatchTup (L _ (Match [p] ty (GRHSs guards wheres))) = do { ss1 <- mkGenSyms (collectPatBinders p) ; addBinds ss1 $ do { ; p1 <- repLP p @@ -559,7 +559,7 @@ repMatchTup (L _ (Match [p] ty (GRHSs guards wheres ty2))) = ; wrapGenSyns (ss1++ss2) match }}} repClauseTup :: LMatch Name -> DsM (Core TH.ClauseQ) -repClauseTup (L _ (Match ps ty (GRHSs guards wheres ty2))) = +repClauseTup (L _ (Match ps ty (GRHSs guards wheres))) = do { ss1 <- mkGenSyms (collectPatsBinders ps) ; addBinds ss1 $ do { ps1 <- repLPs ps @@ -695,7 +695,7 @@ rep_bind :: LHsBind Name -> DsM (SrcSpan, Core TH.DecQ) -- Note GHC treats declarations of a variable (not a pattern) -- e.g. x = g 5 as a Fun MonoBinds. This is indicated by a single match -- with an empty list of patterns -rep_bind (L loc (FunBind fn infx [L _ (Match [] ty (GRHSs guards wheres ty2))])) +rep_bind (L loc (FunBind fn infx (MatchGroup [L _ (Match [] ty (GRHSs guards wheres))] _))) = do { (ss,wherecore) <- repBinds wheres ; guardcore <- addBinds ss (repGuards guards) ; fn' <- lookupLBinder fn @@ -704,13 +704,13 @@ rep_bind (L loc (FunBind fn infx [L _ (Match [] ty (GRHSs guards wheres ty2))])) ; ans' <- wrapGenSyns ss ans ; return (loc, ans') } -rep_bind (L loc (FunBind fn infx ms)) +rep_bind (L loc (FunBind fn infx (MatchGroup ms _))) = do { ms1 <- mapM repClauseTup ms ; fn' <- lookupLBinder fn ; ans <- repFun fn' (nonEmptyCoreList ms1) ; return (loc, ans) } -rep_bind (L loc (PatBind pat (GRHSs guards wheres ty2))) +rep_bind (L loc (PatBind pat (GRHSs guards wheres) ty2)) = do { patcore <- repLP pat ; (ss,wherecore) <- repBinds wheres ; guardcore <- addBinds ss (repGuards guards) @@ -752,7 +752,7 @@ rep_bind (L loc (VarBind v e)) -- (\ p1 .. pn -> exp) by causing an error. repLambda :: LMatch Name -> DsM (Core TH.ExpQ) -repLambda (L _ (Match ps _ (GRHSs [L _ (GRHS [L _ (ResultStmt e)])] [] _))) +repLambda (L _ (Match ps _ (GRHSs [L _ (GRHS [L _ (ResultStmt e)])] []))) = do { let bndrs = collectPatsBinders ps ; ; ss <- mkGenSyms bndrs ; lam <- addBinds ss ( @@ -1273,7 +1273,7 @@ corePair :: (Core a, Core b) -> Core (a,b) corePair (MkC x, MkC y) = MkC (mkCoreTup [x,y]) coreStringLit :: String -> DsM (Core String) -coreStringLit s = do { z <- mkStringLit s; return(MkC z) } +coreStringLit s = do { z <- mkStringExpr s; return(MkC z) } coreIntLit :: Int -> DsM (Core Int) coreIntLit i = return (MkC (mkIntExpr (fromIntegral i))) diff --git a/ghc/compiler/deSugar/DsMonad.lhs b/ghc/compiler/deSugar/DsMonad.lhs index 7605687d39..b5b85987be 100644 --- a/ghc/compiler/deSugar/DsMonad.lhs +++ b/ghc/compiler/deSugar/DsMonad.lhs @@ -31,14 +31,13 @@ import TcRnMonad import HsSyn ( HsExpr, HsMatchContext, Pat ) import TcIface ( tcIfaceGlobal ) import HscTypes ( TyThing(..), TypeEnv, HscEnv, - IsBootInterface, tyThingId, tyThingTyCon, tyThingDataCon ) import Bag ( emptyBag, snocBag, Bag ) import DataCon ( DataCon ) import TyCon ( TyCon ) import DataCon ( DataCon ) import Id ( mkSysLocal, setIdUnique, Id ) -import Module ( Module, ModuleName, ModuleEnv ) +import Module ( Module ) import Var ( TyVar, setTyVarUnique ) import Outputable import SrcLoc ( noSrcSpan, SrcSpan ) diff --git a/ghc/compiler/deSugar/DsUtils.lhs b/ghc/compiler/deSugar/DsUtils.lhs index 7eab67f6e1..931bcc9029 100644 --- a/ghc/compiler/deSugar/DsUtils.lhs +++ b/ghc/compiler/deSugar/DsUtils.lhs @@ -7,22 +7,23 @@ This module exports some utility functions of no great interest. \begin{code} module DsUtils ( - CanItFail(..), EquationInfo(..), MatchResult(..), - EqnNo, EqnSet, - - tidyLitPat, tidyNPat, + EquationInfo(..), + firstPat, shiftEqns, mkDsLet, - cantFailMatchResult, extractMatchResult, - combineMatchResults, - adjustMatchResult, adjustMatchResultDs, - mkCoLetsMatchResult, mkGuardedMatchResult, + MatchResult(..), CanItFail(..), + cantFailMatchResult, alwaysFailMatchResult, + extractMatchResult, combineMatchResults, + adjustMatchResult, adjustMatchResultDs, + mkCoLetsMatchResult, mkCoLetMatchResult, + mkGuardedMatchResult, mkCoPrimCaseMatchResult, mkCoAlgCaseMatchResult, + bindInMatchResult, bindOneInMatchResult, mkErrorAppDs, mkNilExpr, mkConsExpr, mkListExpr, mkIntExpr, mkCharExpr, - mkStringLit, mkStringLitFS, mkIntegerExpr, + mkStringExpr, mkStringExprFS, mkIntegerExpr, mkSelectorBinds, mkTupleExpr, mkTupleSelector, mkTupleType, mkTupleCase, mkBigCoreTup, @@ -30,7 +31,7 @@ module DsUtils ( dsReboundNames, lookupReboundName, - selectMatchVarL, selectMatchVar + selectSimpleMatchVarL, selectMatchVars ) where #include "HsVersions.h" @@ -47,29 +48,28 @@ import DsMonad import CoreUtils ( exprType, mkIfThenElse, mkCoerce, bindNonRec ) import MkId ( iRREFUT_PAT_ERROR_ID, mkReboxingAlt, mkNewTypeBody ) import Id ( idType, Id, mkWildId, mkTemplateLocals, mkSysLocal ) +import Var ( Var ) import Name ( Name ) -import Literal ( Literal(..), inIntRange, tARGET_MAX_INT ) +import Literal ( Literal(..), mkStringLit, inIntRange, tARGET_MAX_INT ) import TyCon ( isNewTyCon, tyConDataCons ) -import DataCon ( DataCon, dataConSourceArity ) -import Type ( mkFunTy, isUnLiftedType, Type, splitTyConApp ) -import TcType ( tcTyConAppTyCon, isIntTy, isFloatTy, isDoubleTy ) +import DataCon ( DataCon, dataConSourceArity, dataConTyCon ) +import Type ( mkFunTy, isUnLiftedType, Type, splitTyConApp, mkTyVarTy ) +import TcType ( tcTyConAppTyCon, tcEqType ) import TysPrim ( intPrimTy ) import TysWiredIn ( nilDataCon, consDataCon, tupleCon, mkTupleTy, unitDataConId, unitTy, charTy, charDataCon, intTy, intDataCon, - floatDataCon, - doubleDataCon, - stringTy, isPArrFakeCon ) + isPArrFakeCon ) import BasicTypes ( Boxity(..) ) -import UniqSet ( mkUniqSet, minusUniqSet, isEmptyUniqSet, UniqSet ) +import UniqSet ( mkUniqSet, minusUniqSet, isEmptyUniqSet ) import UniqSupply ( splitUniqSupply, uniqFromSupply, uniqsFromSupply ) import PrelNames ( unpackCStringName, unpackCStringUtf8Name, plusIntegerName, timesIntegerName, smallIntegerDataConName, lengthPName, indexPName ) import Outputable -import UnicodeUtil ( intsToUtf8, stringToUtf8 ) +import UnicodeUtil ( intsToUtf8 ) import SrcLoc ( Located(..), unLoc, noLoc ) import Util ( isSingleton, notNull, zipEqual ) import ListSetOps ( assocDefault ) @@ -111,43 +111,6 @@ lookupReboundName prs std_name %************************************************************************ %* * -\subsection{Tidying lit pats} -%* * -%************************************************************************ - -\begin{code} -tidyLitPat :: HsLit -> LPat Id -> LPat Id -tidyLitPat (HsChar c) pat = mkCharLitPat c -tidyLitPat lit pat = pat - -tidyNPat :: HsLit -> Type -> LPat Id -> LPat Id -tidyNPat (HsString s) _ pat - | lengthFS s <= 1 -- Short string literals only - = foldr (\c pat -> mkPrefixConPat consDataCon [mkCharLitPat c,pat] stringTy) - (mkNilPat stringTy) (unpackFS s) - -- The stringTy is the type of the whole pattern, not - -- the type to instantiate (:) or [] with! - where - -tidyNPat lit lit_ty default_pat - | isIntTy lit_ty = mkPrefixConPat intDataCon [noLoc $ LitPat (mk_int lit)] lit_ty - | isFloatTy lit_ty = mkPrefixConPat floatDataCon [noLoc $ LitPat (mk_float lit)] lit_ty - | isDoubleTy lit_ty = mkPrefixConPat doubleDataCon [noLoc $ LitPat (mk_double lit)] lit_ty - | otherwise = default_pat - - where - mk_int (HsInteger i _) = HsIntPrim i - - mk_float (HsInteger i _) = HsFloatPrim (fromInteger i) - mk_float (HsRat f _) = HsFloatPrim f - - mk_double (HsInteger i _) = HsDoublePrim (fromInteger i) - mk_double (HsRat f _) = HsDoublePrim f -\end{code} - - -%************************************************************************ -%* * \subsection{Building lets} %* * %************************************************************************ @@ -158,7 +121,8 @@ back again. \begin{code} mkDsLet :: CoreBind -> CoreExpr -> CoreExpr mkDsLet (NonRec bndr rhs) body - | isUnLiftedType (idType bndr) = Case rhs bndr [(DEFAULT,[],body)] + | isUnLiftedType (idType bndr) + = Case rhs bndr (exprType body) [(DEFAULT,[],body)] mkDsLet bind body = Let bind body @@ -179,14 +143,36 @@ hand, which should indeed be bound to the pattern as a whole, then use it; otherwise, make one up. \begin{code} -selectMatchVarL :: LPat Id -> DsM Id -selectMatchVarL pat = selectMatchVar (unLoc pat) - -selectMatchVar (VarPat var) = returnDs var -selectMatchVar (AsPat var pat) = returnDs (unLoc var) -selectMatchVar (LazyPat pat) = selectMatchVarL pat -selectMatchVar other_pat = newSysLocalDs (hsPatType (noLoc other_pat)) - -- OK, better make up one... +selectSimpleMatchVarL :: LPat Id -> DsM Id +selectSimpleMatchVarL pat = selectMatchVar (unLoc pat) (hsPatType pat) + +-- (selectMatchVars ps tys) chooses variables of type tys +-- to use for matching ps against. If the pattern is a variable, +-- we try to use that, to save inventing lots of fresh variables. +-- But even if it is a variable, its type might not match. Consider +-- data T a where +-- T1 :: Int -> T Int +-- T2 :: a -> T a +-- +-- f :: T a -> a -> Int +-- f (T1 i) (x::Int) = x +-- f (T2 i) (y::a) = 0 +-- Then we must not choose (x::Int) as the matching variable! + +selectMatchVars :: [Pat Id] -> [Type] -> DsM [Id] +selectMatchVars [] [] = return [] +selectMatchVars (p:ps) (ty:tys) = do { v <- selectMatchVar p ty + ; vs <- selectMatchVars ps tys + ; return (v:vs) } + +selectMatchVar (LazyPat pat) pat_ty = selectMatchVar (unLoc pat) pat_ty +selectMatchVar (VarPat var) pat_ty = try_for var pat_ty +selectMatchVar (AsPat var pat) pat_ty = try_for (unLoc var) pat_ty +selectMatchVar other_pat pat_ty = newSysLocalDs pat_ty -- OK, better make up one... + +try_for var pat_ty + | idType var `tcEqType` pat_ty = returnDs var + | otherwise = newSysLocalDs pat_ty \end{code} @@ -201,25 +187,30 @@ The ``equation info'' used by @match@ is relatively complicated and worthy of a type synonym and a few handy functions. \begin{code} - -type EqnNo = Int -type EqnSet = UniqSet EqnNo - data EquationInfo - = EqnInfo - EqnNo -- The number of the equation + = EqnInfo { eqn_pats :: [Pat Id], -- The patterns for an eqn + eqn_rhs :: MatchResult } -- What to do after match + +-- The semantics of (match vs (EqnInfo wrap pats rhs)) is the MatchResult +-- \fail. wrap (case vs of { pats -> rhs fail }) +-- where vs are not in the domain of wrap - DsMatchContext -- The context info is used when producing warnings - -- about shadowed patterns. It's the context - -- of the *first* thing matched in this group. - -- Should perhaps be a list of them all! +firstPat :: EquationInfo -> Pat Id +firstPat eqn = head (eqn_pats eqn) - [Pat Id] -- The patterns for an eqn +shiftEqns :: [EquationInfo] -> [EquationInfo] +-- Drop the outermost layer of the first pattern in each equation +shiftEqns eqns = [ eqn { eqn_pats = shiftPats (eqn_pats eqn) } + | eqn <- eqns ] - MatchResult -- Encapsulates the guards and bindings +shiftPats :: [Pat Id] -> [Pat Id] +shiftPats (ConPatOut _ _ _ _ (PrefixCon arg_pats) _ : pats) = map unLoc arg_pats ++ pats +shiftPats (pat_with_no_sub_pats : pats) = pats \end{code} + \begin{code} +-- A MatchResult is an expression with a hole in it data MatchResult = MatchResult CanItFail -- Tells whether the failure expression is used @@ -237,6 +228,9 @@ orFail _ _ = CanFail Functions on MatchResults \begin{code} +alwaysFailMatchResult :: MatchResult +alwaysFailMatchResult = MatchResult CanFail (\fail -> returnDs fail) + cantFailMatchResult :: CoreExpr -> MatchResult cantFailMatchResult expr = MatchResult CantFail (\ ignore -> returnDs expr) @@ -263,7 +257,6 @@ combineMatchResults (MatchResult CanFail body_fn1) combineMatchResults match_result1@(MatchResult CantFail body_fn1) match_result2 = match_result1 - adjustMatchResult :: (CoreExpr -> CoreExpr) -> MatchResult -> MatchResult adjustMatchResult encl_fn (MatchResult can_it_fail body_fn) = MatchResult can_it_fail (\fail -> body_fn fail `thenDs` \ body -> @@ -274,11 +267,27 @@ adjustMatchResultDs encl_fn (MatchResult can_it_fail body_fn) = MatchResult can_it_fail (\fail -> body_fn fail `thenDs` \ body -> encl_fn body) +bindInMatchResult :: [(Var,Var)] -> MatchResult -> MatchResult +bindInMatchResult binds = adjustMatchResult (\e -> foldr bind e binds) + where + bind (new,old) body = bindMR new old body + +bindOneInMatchResult :: Var -> Var -> MatchResult -> MatchResult +bindOneInMatchResult new old = adjustMatchResult (bindMR new old) + +bindMR :: Var -> Var -> CoreExpr -> CoreExpr +bindMR new old body + | new==old = body + | isTyVar new = App (Lam new body) (Type (mkTyVarTy old)) + | otherwise = Let (NonRec new (Var old)) body mkCoLetsMatchResult :: [CoreBind] -> MatchResult -> MatchResult mkCoLetsMatchResult binds match_result = adjustMatchResult (mkDsLets binds) match_result +mkCoLetMatchResult :: CoreBind -> MatchResult -> MatchResult +mkCoLetMatchResult bind match_result + = adjustMatchResult (mkDsLet bind) match_result mkGuardedMatchResult :: CoreExpr -> MatchResult -> MatchResult mkGuardedMatchResult pred_expr (MatchResult can_it_fail body_fn) @@ -286,27 +295,28 @@ mkGuardedMatchResult pred_expr (MatchResult can_it_fail body_fn) returnDs (mkIfThenElse pred_expr body fail)) mkCoPrimCaseMatchResult :: Id -- Scrutinee + -> Type -- Type of the case -> [(Literal, MatchResult)] -- Alternatives -> MatchResult -mkCoPrimCaseMatchResult var match_alts +mkCoPrimCaseMatchResult var ty match_alts = MatchResult CanFail mk_case where mk_case fail = mappM (mk_alt fail) match_alts `thenDs` \ alts -> - returnDs (Case (Var var) var ((DEFAULT, [], fail) : alts)) + returnDs (Case (Var var) var ty ((DEFAULT, [], fail) : alts)) mk_alt fail (lit, MatchResult _ body_fn) = body_fn fail `thenDs` \ body -> returnDs (LitAlt lit, [], body) mkCoAlgCaseMatchResult :: Id -- Scrutinee + -> Type -- Type of exp -> [(DataCon, [CoreBndr], MatchResult)] -- Alternatives -> MatchResult - -mkCoAlgCaseMatchResult var match_alts +mkCoAlgCaseMatchResult var ty match_alts | isNewTyCon tycon -- Newtype case; use a let - = ASSERT( null (tail match_alts) && null (tail arg_ids) ) - mkCoLetsMatchResult [NonRec arg_id newtype_rhs] match_result + = ASSERT( null (tail match_alts) && null (tail arg_ids1) ) + mkCoLetsMatchResult [NonRec arg_id1 newtype_rhs] match_result1 | isPArrFakeAlts match_alts -- Sugared parallel array; use a literal case = MatchResult CanFail mk_parrCase @@ -314,14 +324,14 @@ mkCoAlgCaseMatchResult var match_alts | otherwise -- Datatype case; use a case = MatchResult fail_flag mk_case where - -- Common stuff - scrut_ty = idType var - tycon = tcTyConAppTyCon scrut_ty -- Newtypes must be opaque here + tycon = dataConTyCon con1 + -- [Interesting: becuase of GADTs, we can't rely on the type of + -- the scrutinised Id to be sufficiently refined to have a TyCon in it] -- Stuff for newtype - (_, arg_ids, match_result) = head match_alts - arg_id = head arg_ids - newtype_rhs = mkNewTypeBody tycon (idType arg_id) (Var var) + (con1, arg_ids1, match_result1) = head match_alts + arg_id1 = head arg_ids1 + newtype_rhs = mkNewTypeBody tycon (idType arg_id1) (Var var) -- Stuff for data types data_cons = tyConDataCons tycon @@ -334,7 +344,7 @@ mkCoAlgCaseMatchResult var match_alts wild_var = mkWildId (idType var) mk_case fail = mappM (mk_alt fail) match_alts `thenDs` \ alts -> - returnDs (Case (Var var) wild_var (mk_default fail ++ alts)) + returnDs (Case (Var var) wild_var ty (mk_default fail ++ alts)) mk_alt fail (con, args, MatchResult _ body_fn) = body_fn fail `thenDs` \ body -> @@ -381,7 +391,7 @@ mkCoAlgCaseMatchResult var match_alts mk_parrCase fail = dsLookupGlobalId lengthPName `thenDs` \lengthP -> unboxAlt `thenDs` \alt -> - returnDs (Case (len lengthP) (mkWildId intTy) [alt]) + returnDs (Case (len lengthP) (mkWildId intTy) ty [alt]) where elemTy = case splitTyConApp (idType var) of (_, [elemTy]) -> elemTy @@ -393,7 +403,7 @@ mkCoAlgCaseMatchResult var match_alts newSysLocalDs intPrimTy `thenDs` \l -> dsLookupGlobalId indexPName `thenDs` \indexP -> mappM (mkAlt indexP) match_alts `thenDs` \alts -> - returnDs (DataAlt intDataCon, [l], (Case (Var l) wild (dft : alts))) + returnDs (DataAlt intDataCon, [l], (Case (Var l) wild ty (dft : alts))) where wild = mkWildId intPrimTy dft = (DEFAULT, [], fail) @@ -431,7 +441,7 @@ mkErrorAppDs err_id ty msg = getSrcSpanDs `thenDs` \ src_loc -> let full_msg = showSDoc (hcat [ppr src_loc, text "|", text msg]) - core_msg = Lit (MachStr (mkFastString (stringToUtf8 full_msg))) + core_msg = Lit (mkStringLit full_msg) in returnDs (mkApps (Var err_id) [Type ty, core_msg]) \end{code} @@ -444,11 +454,11 @@ mkErrorAppDs err_id ty msg %************************************************************************ \begin{code} -mkCharExpr :: Char -> CoreExpr -- Returns C# c :: Int -mkIntExpr :: Integer -> CoreExpr -- Returns I# i :: Int -mkIntegerExpr :: Integer -> DsM CoreExpr -- Result :: Integer -mkStringLit :: String -> DsM CoreExpr -- Result :: String -mkStringLitFS :: FastString -> DsM CoreExpr -- Result :: String +mkCharExpr :: Char -> CoreExpr -- Returns C# c :: Int +mkIntExpr :: Integer -> CoreExpr -- Returns I# i :: Int +mkIntegerExpr :: Integer -> DsM CoreExpr -- Result :: Integer +mkStringExpr :: String -> DsM CoreExpr -- Result :: String +mkStringExprFS :: FastString -> DsM CoreExpr -- Result :: String mkIntExpr i = mkConApp intDataCon [mkIntLit i] mkCharExpr c = mkConApp charDataCon [mkLit (MachChar c)] @@ -486,9 +496,9 @@ mkIntegerExpr i mkSmallIntegerLit small_integer_data_con i = mkConApp small_integer_data_con [mkIntLit i] -mkStringLit str = mkStringLitFS (mkFastString str) +mkStringExpr str = mkStringExprFS (mkFastString str) -mkStringLitFS str +mkStringExprFS str | nullFastString str = returnDs (mkNilExpr charTy) @@ -602,11 +612,11 @@ mkSelectorBinds pat val_expr is_simple_lpat p = is_simple_pat (unLoc p) - is_simple_pat (TuplePat ps Boxed) = all is_triv_lpat ps - is_simple_pat (ConPatOut _ ps _ _ _) = all is_triv_lpat (hsConArgs ps) - is_simple_pat (VarPat _) = True - is_simple_pat (ParPat p) = is_simple_lpat p - is_simple_pat other = False + is_simple_pat (TuplePat ps Boxed) = all is_triv_lpat ps + is_simple_pat (ConPatOut _ _ _ _ ps _) = all is_triv_lpat (hsConArgs ps) + is_simple_pat (VarPat _) = True + is_simple_pat (ParPat p) = is_simple_lpat p + is_simple_pat other = False is_triv_lpat p = is_triv_pat (unLoc p) @@ -762,7 +772,9 @@ mkSmallTupleCase mkSmallTupleCase [var] body _scrut_var scrut = bindNonRec var scrut body mkSmallTupleCase vars body scrut_var scrut - = Case scrut scrut_var [(DataAlt (tupleCon Boxed (length vars)), vars, body)] +-- gaw 2004 +-- One branch no refinement? + = Case scrut scrut_var (exprType body) [(DataAlt (tupleCon Boxed (length vars)), vars, body)] \end{code} %************************************************************************ @@ -812,7 +824,8 @@ mkCoreSel [var] should_be_the_same_var scrut_var scrut mkCoreSel vars the_var scrut_var scrut = ASSERT( notNull vars ) - Case scrut scrut_var +-- gaw 2004 + Case scrut scrut_var (idType the_var) [(DataAlt (tupleCon Boxed (length vars)), vars, Var the_var)] \end{code} diff --git a/ghc/compiler/deSugar/Match.hi-boot-6 b/ghc/compiler/deSugar/Match.hi-boot-6 index dcc479bed4..abd5d2bc2f 100644 --- a/ghc/compiler/deSugar/Match.hi-boot-6 +++ b/ghc/compiler/deSugar/Match.hi-boot-6 @@ -1,13 +1,14 @@ module Match where match :: [Var.Id] + -> TcType.TcType -> [DsUtils.EquationInfo] -> DsMonad.DsM DsUtils.MatchResult -matchExport - :: [Var.Id] - -> [DsUtils.EquationInfo] - -> DsMonad.DsM DsUtils.MatchResult +matchWrapper + :: HsExpr.HsMatchContext Name.Name + -> HsExpr.MatchGroup Var.Id + -> DsMonad.DsM ([Var.Id], CoreSyn.CoreExpr) matchSimply :: CoreSyn.CoreExpr @@ -21,5 +22,6 @@ matchSinglePat :: CoreSyn.CoreExpr -> DsMonad.DsMatchContext -> HsPat.LPat Var.Id + -> TcType.TcType -> DsUtils.MatchResult -> DsMonad.DsM DsUtils.MatchResult diff --git a/ghc/compiler/deSugar/Match.lhs b/ghc/compiler/deSugar/Match.lhs index 295b780dd9..150cdc675d 100644 --- a/ghc/compiler/deSugar/Match.lhs +++ b/ghc/compiler/deSugar/Match.lhs @@ -4,32 +4,33 @@ \section[Main_match]{The @match@ function} \begin{code} -module Match ( match, matchExport, matchWrapper, matchSimply, matchSinglePat ) where +module Match ( match, matchWrapper, matchSimply, matchSinglePat ) where #include "HsVersions.h" -import {-# SOURCE #-} DsExpr( dsExpr ) import CmdLineOpts ( DynFlag(..), dopt ) import HsSyn import TcHsSyn ( hsPatType ) import Check ( check, ExhaustivePat ) import CoreSyn -import CoreUtils ( bindNonRec ) +import CoreUtils ( bindNonRec, exprType ) import DsMonad +import DsBinds ( dsHsNestedBinds ) import DsGRHSs ( dsGRHSs ) import DsUtils -import Id ( idType, recordSelectorFieldLabel, Id ) -import DataCon ( dataConFieldLabels, dataConInstOrigArgTys ) +import Id ( idName, idType, Id ) +import DataCon ( dataConFieldLabels, dataConInstOrigArgTys, isVanillaDataCon ) import MatchCon ( matchConFamily ) -import MatchLit ( matchLiterals ) +import MatchLit ( matchLiterals, matchNPlusKPats, matchNPats, tidyLitPat, tidyNPat ) import PrelInfo ( pAT_ERROR_ID ) -import TcType ( mkTyVarTys, Type, tcTyConAppArgs, tcEqType ) +import TcType ( Type, tcTyConAppArgs ) +import Type ( splitFunTysN ) import TysWiredIn ( consDataCon, mkTupleTy, mkListTy, tupleCon, parrFakeCon, mkPArrTy ) import BasicTypes ( Boxity(..) ) -import UniqSet +import ListSetOps ( runs ) import SrcLoc ( noSrcSpan, noLoc, unLoc, Located(..) ) -import Util ( lengthExceeds, isSingleton, notNull ) +import Util ( lengthExceeds, notNull ) import Name ( Name ) import Outputable \end{code} @@ -42,36 +43,34 @@ It can not be called matchWrapper because this name already exists :-( JJCQ 30-Nov-1997 \begin{code} -matchExport :: [Id] -- Vars rep'ing the exprs we're matching with +matchCheck :: DsMatchContext + -> [Id] -- Vars rep'ing the exprs we're matching with + -> Type -- Type of the case expression -> [EquationInfo] -- Info about patterns, etc. (type synonym below) -> DsM MatchResult -- Desugared result! - -matchExport vars qs +matchCheck ctx vars ty qs = getDOptsDs `thenDs` \ dflags -> - matchExport_really dflags vars qs + matchCheck_really dflags ctx vars ty qs -matchExport_really dflags vars qs@((EqnInfo _ ctx _ (MatchResult _ _)) : _) +matchCheck_really dflags ctx vars ty qs | incomplete && shadow = dsShadowWarn ctx eqns_shadow `thenDs` \ () -> dsIncompleteWarn ctx pats `thenDs` \ () -> - match vars qs + match vars ty qs | incomplete = dsIncompleteWarn ctx pats `thenDs` \ () -> - match vars qs + match vars ty qs | shadow = dsShadowWarn ctx eqns_shadow `thenDs` \ () -> - match vars qs + match vars ty qs | otherwise = - match vars qs - where (pats,indexs) = check qs + match vars ty qs + where (pats, eqns_shadow) = check qs incomplete = dopt Opt_WarnIncompletePatterns dflags && (notNull pats) shadow = dopt Opt_WarnOverlappingPatterns dflags - && sizeUniqSet indexs < no_eqns - no_eqns = length qs - unused_eqns = uniqSetToList (mkUniqSet [1..no_eqns] `minusUniqSet` indexs) - eqns_shadow = map (\n -> qs!!(n - 1)) unused_eqns + && not (null eqns_shadow) \end{code} This variable shows the maximum number of lines of output generated for warnings. @@ -135,7 +134,7 @@ ppr_incomplete_pats kind (pats,constraints) = ppr_constraint (var,pats) = sep [ppr var, ptext SLIT("`notElem`"), ppr pats] -ppr_eqn prefixF kind (EqnInfo _ _ pats _) = prefixF (ppr_shadow_pats kind pats) +ppr_eqn prefixF kind eqn = prefixF (ppr_shadow_pats kind (eqn_pats eqn)) \end{code} @@ -192,6 +191,7 @@ chance of working in our post-upheaval world of @Locals@.) So, the full type signature: \begin{code} match :: [Id] -- Variables rep'ing the exprs we're matching with + -> Type -- Type of the case expression -> [EquationInfo] -- Info about patterns, etc. (type synonym below) -> DsM MatchResult -- Desugared result! \end{code} @@ -239,11 +239,13 @@ than the Wadler-chapter code for @match@ (p.~93, first @match@ clause). And gluing the ``success expressions'' together isn't quite so pretty. \begin{code} -match [] eqns_info - = returnDs (foldr1 combineMatchResults match_results) +match [] ty eqns_info + = ASSERT( not (null eqns_info) ) + returnDs (foldr1 combineMatchResults match_results) where - match_results = [ ASSERT( null pats) mr - | EqnInfo _ _ pats mr <- eqns_info ] + match_results = [ ASSERT( null (eqn_pats eqn) ) + eqn_rhs eqn + | eqn <- eqns_info ] \end{code} @@ -266,27 +268,39 @@ Wadler-chapter @match@ (p.~93, last clause), and @match_unmixed_blk@ corresponds roughly to @matchVarCon@. \begin{code} -match vars@(v:vs) eqns_info - = mappM (tidyEqnInfo v) eqns_info `thenDs` \ tidy_eqns_info -> - let - tidy_eqns_blks = unmix_eqns tidy_eqns_info - in - mappM (matchEqnBlock vars) tidy_eqns_blks `thenDs` \ match_results -> - returnDs (foldr1 combineMatchResults match_results) +match vars@(v:_) ty eqns_info + = do { tidy_eqns <- mappM (tidyEqnInfo v) eqns_info + ; let eqns_blks = runs same_family tidy_eqns + ; match_results <- mappM match_block eqns_blks + ; ASSERT( not (null match_results) ) + return (foldr1 combineMatchResults match_results) } where - unmix_eqns [] = [] - unmix_eqns [eqn] = [ [eqn] ] - unmix_eqns (eq1@(EqnInfo _ _ (p1:p1s) _) : eq2@(EqnInfo _ _ (p2:p2s) _) : eqs) - = if ( (isWildPat p1 && isWildPat p2) - || (isConPat p1 && isConPat p2) - || (isLitPat p1 && isLitPat p2) ) then - eq1 `tack_onto` unmixed_rest - else - [ eq1 ] : unmixed_rest - where - unmixed_rest = unmix_eqns (eq2:eqs) - - x `tack_onto` xss = ( x : head xss) : tail xss + same_family eqn1 eqn2 + = samePatFamily (firstPat eqn1) (firstPat eqn2) + + match_block eqns + = case firstPat (head eqns) of + WildPat {} -> matchVariables vars ty eqns + ConPatOut {} -> matchConFamily vars ty eqns + NPlusKPatOut {} -> matchNPlusKPats vars ty eqns + NPatOut {} -> matchNPats vars ty eqns + LitPat {} -> matchLiterals vars ty eqns + +-- After tidying, there are only five kinds of patterns +samePatFamily (WildPat {}) (WildPat {}) = True +samePatFamily (ConPatOut {}) (ConPatOut {}) = True +samePatFamily (NPlusKPatOut {}) (NPlusKPatOut {}) = True +samePatFamily (NPatOut {}) (NPatOut {}) = True +samePatFamily (LitPat {}) (LitPat {}) = True +samePatFamily _ _ = False + +matchVariables :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult +-- Real true variables, just like in matchVar, SLPJ p 94 +-- No binding to do: they'll all be wildcards by now (done in tidy) +matchVariables (var:vars) ty eqns = match vars ty (shiftEqns eqns) +\end{code} + + \end{code} Tidy up the leftmost pattern in an @EquationInfo@, given the variable @v@ @@ -326,7 +340,8 @@ Float, Double, at least) are converted to unboxed form; e.g., \begin{code} tidyEqnInfo :: Id -> EquationInfo -> DsM EquationInfo - -- DsM'd because of internal call to "match". + -- DsM'd because of internal call to dsHsNestedBinds + -- and mkSelectorBinds. -- "tidy1" does the interesting stuff, looking at -- one pattern and fiddling the list of bindings. -- @@ -336,21 +351,31 @@ tidyEqnInfo :: Id -> EquationInfo -> DsM EquationInfo -- NPat -- LitPat -- NPlusKPat - -- SigPat -- but no other -tidyEqnInfo v (EqnInfo n ctx (pat : pats) match_result) - = tidy1 v pat match_result `thenDs` \ (pat', match_result') -> - returnDs (EqnInfo n ctx (pat' : pats) match_result') - +tidyEqnInfo v eqn@(EqnInfo { eqn_pats = pat : pats, eqn_rhs = rhs }) + = tidy1 v pat rhs `thenDs` \ (pat', rhs') -> + returnDs (eqn { eqn_pats = pat' : pats, eqn_rhs = rhs' }) tidy1 :: Id -- The Id being scrutinised -> Pat Id -- The pattern against which it is to be matched - -> MatchResult -- Current thing do do after matching + -> MatchResult -- What to do afterwards -> DsM (Pat Id, -- Equivalent pattern - MatchResult) -- Augmented thing to do afterwards - -- The augmentation usually takes the form - -- of new bindings to be added to the front + MatchResult) -- Extra bindings around what to do afterwards + +-- The extra bindings etc are all wrapped around the RHS of the match +-- so they are only available when matching is complete. But that's ok +-- becuase, for example, in the pattern x@(...), the x can only be +-- used in the RHS, not in the nested pattern, nor subsquent patterns +-- +-- However this does have an awkward consequence. The bindings in +-- a VarPatOut get wrapped around the result in right to left order, +-- rather than left to right. This only matters if one set of +-- bindings can mention things used in another, and that can happen +-- if we allow equality dictionary bindings of form d1=d2. +-- bindIInstsOfLocalFuns is now careful not to do this, but it's a wart. +-- (Without this care in bindInstsOfLocalFuns, compiling +-- Data.Generics.Schemes.hs fails in function everywhereBut.) ------------------------------------------------------- -- (pat', mr') = tidy1 v pat mr @@ -358,33 +383,31 @@ tidy1 :: Id -- The Id being scrutinised -- It eliminates many pattern forms (as-patterns, variable patterns, -- list patterns, etc) yielding one of: -- WildPat --- ConPat +-- ConPatOut -- LitPat -- NPat -- NPlusKPat --- -tidy1 v (ParPat pat) match_result - = tidy1 v (unLoc pat) match_result +tidy1 v (ParPat pat) wrap = tidy1 v (unLoc pat) wrap +tidy1 v (SigPatOut pat _) wrap = tidy1 v (unLoc pat) wrap +tidy1 v (WildPat ty) wrap = returnDs (WildPat ty, wrap) -- case v of { x -> mr[] } -- = case v of { _ -> let x=v in mr[] } -tidy1 v (VarPat var) match_result - = returnDs (WildPat (idType var), match_result') - where - match_result' | v == var = match_result - | otherwise = adjustMatchResult (bindNonRec var (Var v)) match_result +tidy1 v (VarPat var) rhs + = returnDs (WildPat (idType var), bindOneInMatchResult var v rhs) + +tidy1 v (VarPatOut var binds) rhs + = do { prs <- dsHsNestedBinds binds + ; return (WildPat (idType var), + bindOneInMatchResult var v $ + mkCoLetMatchResult (Rec prs) rhs) } -- case v of { x@p -> mr[] } -- = case v of { p -> let x=v in mr[] } -tidy1 v (AsPat (L _ var) pat) match_result - = tidy1 v (unLoc pat) match_result' - where - match_result' | v == var = match_result - | otherwise = adjustMatchResult (bindNonRec var (Var v)) match_result +tidy1 v (AsPat (L _ var) pat) rhs + = tidy1 v (unLoc pat) (bindOneInMatchResult var v rhs) -tidy1 v (WildPat ty) match_result - = returnDs (WildPat ty, match_result) {- now, here we handle lazy patterns: tidy1 v ~p bs = (v, v1 = case v of p -> v1 : @@ -397,90 +420,93 @@ tidy1 v (WildPat ty) match_result The case expr for v_i is just: match [v] [(p, [], \ x -> Var v_i)] any_expr -} -tidy1 v (LazyPat pat) match_result - = mkSelectorBinds pat (Var v) `thenDs` \ sel_binds -> - returnDs (WildPat (idType v), - mkCoLetsMatchResult [NonRec b rhs | (b,rhs) <- sel_binds] match_result) +tidy1 v (LazyPat pat) rhs + = do { v' <- newSysLocalDs (idType v) + ; sel_prs <- mkSelectorBinds pat (Var v) + ; let sel_binds = [NonRec b rhs | (b,rhs) <- sel_prs] + ; returnDs (WildPat (idType v), + bindOneInMatchResult v' v $ + mkCoLetsMatchResult sel_binds rhs) } -- re-express <con-something> as (ConPat ...) [directly] -tidy1 v (ConPatOut con ps pat_ty ex_tvs dicts) match_result - = returnDs (ConPatOut con tidy_ps pat_ty ex_tvs dicts, match_result) +tidy1 v (ConPatOut con ex_tvs dicts binds ps pat_ty) rhs + = returnDs (ConPatOut con ex_tvs dicts binds tidy_ps pat_ty, rhs) where - tidy_ps = PrefixCon (tidy_con con pat_ty ex_tvs ps) + tidy_ps = PrefixCon (tidy_con con pat_ty ps) -tidy1 v (ListPat pats ty) match_result - = returnDs (unLoc list_ConPat, match_result) +tidy1 v (ListPat pats ty) rhs + = returnDs (unLoc list_ConPat, rhs) where list_ty = mkListTy ty list_ConPat = foldr (\ x y -> mkPrefixConPat consDataCon [x, y] list_ty) (mkNilPat list_ty) pats --- introduce fake parallel array constructors to be able to handle parallel +-- Introduce fake parallel array constructors to be able to handle parallel -- arrays with the existing machinery for constructor pattern --- -tidy1 v (PArrPat pats ty) match_result - = returnDs (unLoc parrConPat, match_result) +tidy1 v (PArrPat pats ty) rhs + = returnDs (unLoc parrConPat, rhs) where arity = length pats parrConPat = mkPrefixConPat (parrFakeCon arity) pats (mkPArrTy ty) -tidy1 v (TuplePat pats boxity) match_result - = returnDs (unLoc tuple_ConPat, match_result) +tidy1 v (TuplePat pats boxity) rhs + = returnDs (unLoc tuple_ConPat, rhs) where arity = length pats tuple_ConPat = mkPrefixConPat (tupleCon boxity arity) pats (mkTupleTy boxity arity (map hsPatType pats)) -tidy1 v (DictPat dicts methods) match_result +tidy1 v (DictPat dicts methods) rhs = case num_of_d_and_ms of - 0 -> tidy1 v (TuplePat [] Boxed) match_result - 1 -> tidy1 v (unLoc (head dict_and_method_pats)) match_result - _ -> tidy1 v (TuplePat dict_and_method_pats Boxed) match_result + 0 -> tidy1 v (TuplePat [] Boxed) rhs + 1 -> tidy1 v (unLoc (head dict_and_method_pats)) rhs + _ -> tidy1 v (TuplePat dict_and_method_pats Boxed) rhs where num_of_d_and_ms = length dicts + length methods dict_and_method_pats = map nlVarPat (dicts ++ methods) -- LitPats: we *might* be able to replace these w/ a simpler form -tidy1 v pat@(LitPat lit) match_result - = returnDs (unLoc (tidyLitPat lit (noLoc pat)), match_result) +tidy1 v pat@(LitPat lit) rhs + = returnDs (unLoc (tidyLitPat lit (noLoc pat)), rhs) -- NPats: we *might* be able to replace these w/ a simpler form -tidy1 v pat@(NPatOut lit lit_ty _) match_result - = returnDs (unLoc (tidyNPat lit lit_ty (noLoc pat)), match_result) +tidy1 v pat@(NPatOut lit lit_ty _) rhs + = returnDs (unLoc (tidyNPat lit lit_ty (noLoc pat)), rhs) -- and everything else goes through unchanged... -tidy1 v non_interesting_pat match_result - = returnDs (non_interesting_pat, match_result) +tidy1 v non_interesting_pat rhs + = returnDs (non_interesting_pat, rhs) -tidy_con data_con pat_ty ex_tvs (PrefixCon ps) = ps -tidy_con data_con pat_ty ex_tvs (InfixCon p1 p2) = [p1,p2] -tidy_con data_con pat_ty ex_tvs (RecCon rpats) +tidy_con data_con pat_ty (PrefixCon ps) = ps +tidy_con data_con pat_ty (InfixCon p1 p2) = [p1,p2] +tidy_con data_con pat_ty (RecCon rpats) | null rpats = -- Special case for C {}, which can be used for -- a constructor that isn't declared to have -- fields at all - map (noLoc.WildPat) con_arg_tys' + map (noLoc . WildPat) con_arg_tys' | otherwise - = map mk_pat tagged_arg_tys + = ASSERT( isVanillaDataCon data_con ) + -- We're in a record case, so the data con must be vanilla + -- and hence no existentials to worry about + map mk_pat tagged_arg_tys where -- Boring stuff to find the arg-tys of the constructor + inst_tys = tcTyConAppArgs pat_ty -- Newtypes must be opaque - con_arg_tys' = dataConInstOrigArgTys data_con (inst_tys ++ mkTyVarTys ex_tvs) - tagged_arg_tys = con_arg_tys' `zip` (dataConFieldLabels data_con) + con_arg_tys' = dataConInstOrigArgTys data_con inst_tys + tagged_arg_tys = con_arg_tys' `zip` dataConFieldLabels data_con -- mk_pat picks a WildPat of the appropriate type for absent fields, -- and the specified pattern for present fields mk_pat (arg_ty, lbl) = - case [ pat | (sel_id,pat) <- rpats, - recordSelectorFieldLabel (unLoc sel_id) == lbl - ] of - (pat:pats) -> ASSERT( null pats ) - pat + case [ pat | (sel_id,pat) <- rpats, idName (unLoc sel_id) == lbl] of + (pat:pats) -> ASSERT( null pats ) pat [] -> noLoc (WildPat arg_ty) \end{code} @@ -551,91 +577,6 @@ Presumably just a variant on the constructor case (as it is now). %************************************************************************ %* * -%* match on an unmixed block: the real business * -%* * -%************************************************************************ -\subsection[matchEqnBlock]{@matchEqnBlock@: getting down to business} - -The function @matchEqnBlock@ is where the matching stuff sets to -work a block of equations, to which the mixture rule has been applied. -Its arguments and results are the same as for the ``top-level'' @match@. - -\begin{code} -matchEqnBlock :: [Id] - -> [EquationInfo] - -> DsM MatchResult - -matchEqnBlock [] _ = panic "matchEqnBlock: no names" - -matchEqnBlock all_vars@(var:vars) eqns_info - | isWildPat first_pat - = ASSERT( all isWildPat column_1_pats ) -- Sanity check - -- Real true variables, just like in matchVar, SLPJ p 94 - -- No binding to do: they'll all be wildcards by now (done in tidy) - match vars remaining_eqns_info - - | isConPat first_pat - = ASSERT( patsAreAllCons column_1_pats ) - matchConFamily all_vars eqns_info - - | isLitPat first_pat - = ASSERT( patsAreAllLits column_1_pats ) - -- see notes in MatchLiteral - -- not worried about the same literal more than once in a column - -- (ToDo: sort this out later) - matchLiterals all_vars eqns_info - - | isSigPat first_pat - = ASSERT( isSingleton eqns_info ) - matchSigPat all_vars (head eqns_info) - where - first_pat = head column_1_pats - column_1_pats = [pat | EqnInfo _ _ (pat:_) _ <- eqns_info] - remaining_eqns_info = [EqnInfo n ctx pats match_result | EqnInfo n ctx (_:pats) match_result <- eqns_info] -\end{code} - -A SigPat is a type coercion and must be handled one at at time. We can't -combine them unless the type of the pattern inside is identical, and we don't -bother to check for that. For example: - - data T = T1 Int | T2 Bool - f :: (forall a. a -> a) -> T -> t - f (g::Int->Int) (T1 i) = T1 (g i) - f (g::Bool->Bool) (T2 b) = T2 (g b) - -We desugar this as follows: - - f = \ g::(forall a. a->a) t::T -> - let gi = g Int - in case t of { T1 i -> T1 (gi i) - other -> - let gb = g Bool - in case t of { T2 b -> T2 (gb b) - other -> fail }} - -Note that we do not treat the first column of patterns as a -column of variables, because the coerced variables (gi, gb) -would be of different types. So we get rather grotty code. -But I don't think this is a common case, and if it was we could -doubtless improve it. - -Meanwhile, the strategy is: - * treat each SigPat coercion (always non-identity coercions) - as a separate block - * deal with the stuff inside, and then wrap a binding round - the result to bind the new variable (gi, gb, etc) - -\begin{code} -matchSigPat :: [Id] -> EquationInfo -> DsM MatchResult -matchSigPat (var:vars) (EqnInfo n ctx (SigPatOut pat ty co_fn : pats) result) - = selectMatchVarL pat `thenDs` \ new_var -> - dsExpr (HsApp (noLoc co_fn) (nlHsVar var)) `thenDs` \ rhs -> - match (new_var:vars) [EqnInfo n ctx (unLoc pat:pats) result] `thenDs` \ result' -> - returnDs (adjustMatchResult (bindNonRec new_var rhs) result') -\end{code} - -%************************************************************************ -%* * %* matchWrapper: a convenient way to call @match@ * %* * %************************************************************************ @@ -680,7 +621,7 @@ Call @match@ with all of this information! \begin{code} matchWrapper :: HsMatchContext Name -- For shadowing warning messages - -> [LMatch Id] -- Matches being desugared + -> MatchGroup Id -- Matches being desugared -> DsM ([Id], CoreExpr) -- Results \end{code} @@ -707,24 +648,35 @@ one pattern, and match simply only accepts one pattern. JJQC 30-Nov-1997 \begin{code} -matchWrapper ctxt matches - = getDOptsDs `thenDs` \ dflags -> - flattenMatches ctxt matches `thenDs` \ (result_ty, eqns_info) -> - let - EqnInfo _ _ arg_pats _ : _ = eqns_info - error_string = matchContextErrString ctxt - in - mappM selectMatchVar arg_pats `thenDs` \ new_vars -> - match_fun dflags new_vars eqns_info `thenDs` \ match_result -> - - mkErrorAppDs pAT_ERROR_ID result_ty error_string `thenDs` \ fail_expr -> - extractMatchResult match_result fail_expr `thenDs` \ result_expr -> - returnDs (new_vars, result_expr) - where match_fun dflags - = case ctxt of - LambdaExpr | dopt Opt_WarnSimplePatterns dflags -> matchExport - | otherwise -> match - _ -> matchExport +matchWrapper ctxt (MatchGroup matches match_ty) + = do { eqns_info <- mapM mk_eqn_info matches + ; dflags <- getDOptsDs + ; locn <- getSrcSpanDs + ; let ds_ctxt = DsMatchContext ctxt arg_pats locn + error_string = matchContextErrString ctxt + + ; new_vars <- selectMatchVars arg_pats pat_tys + ; match_result <- match_fun dflags ds_ctxt new_vars rhs_ty eqns_info + + ; fail_expr <- mkErrorAppDs pAT_ERROR_ID rhs_ty error_string + ; result_expr <- extractMatchResult match_result fail_expr + ; return (new_vars, result_expr) } + where + arg_pats = map unLoc (hsLMatchPats (head matches)) + n_pats = length arg_pats + (pat_tys, rhs_ty) = splitFunTysN n_pats match_ty + + mk_eqn_info (L _ (Match pats _ grhss)) + = do { let upats = map unLoc pats + ; match_result <- dsGRHSs ctxt upats grhss rhs_ty + ; return (EqnInfo { eqn_pats = upats, + eqn_rhs = match_result}) } + + match_fun dflags ds_ctxt + = case ctxt of + LambdaExpr | dopt Opt_WarnSimplePatterns dflags -> matchCheck ds_ctxt + | otherwise -> match + _ -> matchCheck ds_ctxt \end{code} %************************************************************************ @@ -750,54 +702,27 @@ matchSimply scrut kind pat result_expr fail_expr let ctx = DsMatchContext kind [unLoc pat] locn match_result = cantFailMatchResult result_expr + rhs_ty = exprType fail_expr + -- Use exprType of fail_expr, because won't refine in the case of failure! in - matchSinglePat scrut ctx pat match_result `thenDs` \ match_result' -> + matchSinglePat scrut ctx pat rhs_ty match_result `thenDs` \ match_result' -> extractMatchResult match_result' fail_expr matchSinglePat :: CoreExpr -> DsMatchContext -> LPat Id - -> MatchResult -> DsM MatchResult - -matchSinglePat (Var var) ctx pat match_result + -> Type -> MatchResult -> DsM MatchResult +matchSinglePat (Var var) ctx pat ty match_result = getDOptsDs `thenDs` \ dflags -> - match_fn dflags [var] [EqnInfo 1 ctx [unLoc pat] match_result] + match_fn dflags [var] ty [EqnInfo { eqn_pats = [unLoc pat], + eqn_rhs = match_result }] where match_fn dflags - | dopt Opt_WarnSimplePatterns dflags = matchExport + | dopt Opt_WarnSimplePatterns dflags = matchCheck ctx | otherwise = match -matchSinglePat scrut ctx pat match_result - = selectMatchVarL pat `thenDs` \ var -> - matchSinglePat (Var var) ctx pat match_result `thenDs` \ match_result' -> +matchSinglePat scrut ctx pat ty match_result + = selectSimpleMatchVarL pat `thenDs` \ var -> + matchSinglePat (Var var) ctx pat ty match_result `thenDs` \ match_result' -> returnDs (adjustMatchResult (bindNonRec var scrut) match_result') \end{code} -%************************************************************************ -%* * -%* flattenMatches : create a list of EquationInfo * -%* * -%************************************************************************ - -\subsection[flattenMatches]{@flattenMatches@: create @[EquationInfo]@} - -This is actually local to @matchWrapper@. - -\begin{code} -flattenMatches :: HsMatchContext Name - -> [LMatch Id] - -> DsM (Type, [EquationInfo]) - -flattenMatches kind matches - = mapAndUnzipDs flatten_match (matches `zip` [1..]) `thenDs` \ (result_tys, eqn_infos) -> - let - result_ty = head result_tys - in - ASSERT( all (tcEqType result_ty) result_tys ) - returnDs (result_ty, eqn_infos) - where - flatten_match (L _ (Match pats _ grhss), n) - = dsGRHSs kind upats grhss `thenDs` \ (ty, match_result) -> - getSrcSpanDs `thenDs` \ locn -> - returnDs (ty, EqnInfo n (DsMatchContext kind upats locn) upats match_result) - where upats = map unLoc pats -\end{code} diff --git a/ghc/compiler/deSugar/MatchCon.lhs b/ghc/compiler/deSugar/MatchCon.lhs index ed9f894834..62ed087648 100644 --- a/ghc/compiler/deSugar/MatchCon.lhs +++ b/ghc/compiler/deSugar/MatchCon.lhs @@ -10,18 +10,21 @@ module MatchCon ( matchConFamily ) where import {-# SOURCE #-} Match ( match ) -import HsSyn ( Pat(..), HsConDetails(..) ) - +import HsSyn ( Pat(..), HsConDetails(..), isEmptyLHsBinds ) +import DsBinds ( dsHsNestedBinds ) +import DataCon ( isVanillaDataCon, dataConTyVars, dataConOrigArgTys ) +import TcType ( tcTyConAppArgs ) +import Type ( substTys, zipTopTvSubst, mkTyVarTys ) +import CoreSyn import DsMonad import DsUtils import Id ( Id ) -import Subst ( mkSubst, mkInScopeSet, bindSubst, substExpr ) -import CoreFVs ( exprFreeVars ) -import VarEnv ( emptySubstEnv ) +import Type ( Type ) import ListSetOps ( equivClassesByUniq ) import SrcLoc ( unLoc ) import Unique ( Uniquable(..) ) +import Outputable \end{code} We are confronted with the first column of patterns in a set of @@ -76,76 +79,65 @@ have-we-used-all-the-constructors? question; the local function @match_cons_used@ does all the real work. \begin{code} matchConFamily :: [Id] + -> Type -> [EquationInfo] -> DsM MatchResult - -matchConFamily (var:vars) eqns_info +matchConFamily (var:vars) ty eqns_info = let -- Sort into equivalence classes by the unique on the constructor -- All the EqnInfos should start with a ConPat eqn_groups = equivClassesByUniq get_uniq eqns_info - get_uniq (EqnInfo _ _ (ConPatOut data_con _ _ _ _ : _) _) = getUnique data_con + get_uniq (EqnInfo { eqn_pats = ConPatOut data_con _ _ _ _ _ : _}) = getUnique data_con in -- Now make a case alternative out of each group - mappM (match_con vars) eqn_groups `thenDs` \ alts -> - - returnDs (mkCoAlgCaseMatchResult var alts) + mappM (match_con vars ty) eqn_groups `thenDs` \ alts -> + returnDs (mkCoAlgCaseMatchResult var ty alts) \end{code} And here is the local function that does all the work. It is more-or-less the @matchCon@/@matchClause@ functions on page~94 in -Wadler's chapter in SLPJ. +Wadler's chapter in SLPJ. The function @shift_con_pats@ does what the +list comprehension in @matchClause@ (SLPJ, p.~94) does, except things +are trickier in real life. Works for @ConPats@, and we want it to +fail catastrophically for anything else (which a list comprehension +wouldn't). Cf.~@shift_lit_pats@ in @MatchLits@. \begin{code} -match_con vars (eqn1@(EqnInfo _ _ (ConPatOut data_con (PrefixCon arg_pats) _ ex_tvs ex_dicts : _) _) - : other_eqns) - = -- Make new vars for the con arguments; avoid new locals where possible - mappM selectMatchVarL arg_pats `thenDs` \ arg_vars -> - - -- Now do the business to make the alt for _this_ ConPat ... - match (arg_vars ++ vars) - (map shift_con_pat (eqn1:other_eqns)) `thenDs` \ match_result -> - - -- [See "notes on do_subst" below this function] - -- Make the ex_tvs and ex_dicts line up with those - -- in the first pattern. Remember, they are all guaranteed to be variables - let - match_result' | null ex_tvs = match_result - | null other_eqns = match_result - | otherwise = adjustMatchResult do_subst match_result - in +match_con vars ty eqns + = do { -- Make new vars for the con arguments; avoid new locals where possible + arg_vars <- selectMatchVars (map unLoc arg_pats1) arg_tys + + ; match_result <- match (arg_vars ++ vars) ty (shiftEqns eqns) + + ; binds <- mapM ds_binds [ bind | ConPatOut _ _ _ bind _ _ <- pats, + not (isEmptyLHsBinds bind) ] + + ; let match_result' = bindInMatchResult (line_up other_pats) $ + mkCoLetsMatchResult binds match_result - returnDs (data_con, ex_tvs ++ ex_dicts ++ arg_vars, match_result') + ; return (data_con, tvs1 ++ dicts1 ++ arg_vars, match_result') } where - shift_con_pat :: EquationInfo -> EquationInfo - shift_con_pat (EqnInfo n ctx (ConPatOut _ (PrefixCon arg_pats) _ _ _ : pats) match_result) - = EqnInfo n ctx (map unLoc arg_pats ++ pats) match_result - - other_pats = [p | EqnInfo _ _ (p:_) _ <- other_eqns] - - var_prs = concat [ (ex_tvs' `zip` ex_tvs) ++ - (ex_dicts' `zip` ex_dicts) - | ConPatOut _ _ _ ex_tvs' ex_dicts' <- other_pats ] - - do_subst e = substExpr subst e - where - subst = foldl (\ s (v', v) -> bindSubst s v' v) in_scope var_prs - in_scope = mkSubst (mkInScopeSet (exprFreeVars e)) emptySubstEnv - -- We put all the free variables of e into the in-scope - -- set of the substitution, not because it is necessary, - -- but to suppress the warning in Subst.lookupInScope - -- Tiresome, but doing the substitution at all is rare. + pats@(pat1 : other_pats) = map firstPat eqns + ConPatOut data_con tvs1 dicts1 _ (PrefixCon arg_pats1) pat_ty = pat1 + + ds_binds bind = do { prs <- dsHsNestedBinds bind; return (Rec prs) } + + line_up pats + | null tvs1 && null dicts1 = [] -- Common case + | otherwise = [ pr | ConPatOut _ ts ds _ _ _ <- pats, + pr <- (ts `zip` tvs1) ++ (ds `zip` dicts1)] + + -- Get the arg types, which we use to type the new vars + -- to match on, from the "outside"; the types of pats1 may + -- be more refined, and hence won't do + arg_tys = substTys (zipTopTvSubst (dataConTyVars data_con) inst_tys) + (dataConOrigArgTys data_con) + inst_tys | isVanillaDataCon data_con = tcTyConAppArgs pat_ty -- Newtypes opaque! + | otherwise = mkTyVarTys tvs1 \end{code} -Note on @shift_con_pats@ just above: does what the list comprehension in -@matchClause@ (SLPJ, p.~94) does, except things are trickier in real -life. Works for @ConPats@, and we want it to fail catastrophically -for anything else (which a list comprehension wouldn't). -Cf.~@shift_lit_pats@ in @MatchLits@. - - -Notes on do_subst stuff -~~~~~~~~~~~~~~~~~~~~~~~ +Note [Existentials in shift_con_pat] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider data T = forall a. Ord a => T a (a->Int) @@ -155,7 +147,7 @@ Consider When we put in the tyvars etc we get f (T a (d::Ord a) (x::a) (f::a->Int)) True = ...expr1... - f (T b (e::Ord a) (y::a) (g::a->Int)) True = ...expr2... + f (T b (e::Ord b) (y::a) (g::a->Int)) True = ...expr2... After desugaring etc we'll get a single case: @@ -167,12 +159,11 @@ After desugaring etc we'll get a single case: False -> ...expr2... *** We have to substitute [a/b, d/e] in expr2! ** -That is what do_subst is doing. +Hence + False -> ....((/\b\(e:Ord b).expr2) a d).... Originally I tried to use (\b -> let e = d in expr2) a to do this substitution. While this is "correct" in a way, it fails Lint, because e::Ord b but d::Ord a. -So now I simply do the substitution properly using substExpr. - diff --git a/ghc/compiler/deSugar/MatchLit.lhs b/ghc/compiler/deSugar/MatchLit.lhs index d3f04f46af..ea307ac45c 100644 --- a/ghc/compiler/deSugar/MatchLit.lhs +++ b/ghc/compiler/deSugar/MatchLit.lhs @@ -4,7 +4,8 @@ \section[MatchLit]{Pattern-matching literal patterns} \begin{code} -module MatchLit ( dsLit, matchLiterals ) where +module MatchLit ( dsLit, tidyLitPat, tidyNPat, + matchLiterals, matchNPlusKPats, matchNPats ) where #include "HsVersions.h" @@ -18,15 +19,18 @@ import HsSyn import Id ( Id ) import CoreSyn import TyCon ( tyConDataCons ) -import TcType ( tcSplitTyConApp, isIntegerTy ) +import TcType ( tcSplitTyConApp, isIntegerTy, isIntTy, isFloatTy, isDoubleTy ) +import Type ( Type ) import PrelNames ( ratioTyConKey ) +import TysWiredIn ( stringTy, consDataCon, intDataCon, floatDataCon, doubleDataCon ) import Unique ( hasKey ) import Literal ( mkMachInt, Literal(..) ) -import Maybes ( catMaybes ) -import SrcLoc ( noLoc, Located(..), unLoc ) -import Panic ( panic, assertPanic ) +import SrcLoc ( noLoc, unLoc ) +import ListSetOps ( equivClasses, runs ) import Ratio ( numerator, denominator ) +import SrcLoc ( Located(..) ) import Outputable +import FastString ( lengthFS, unpackFS ) \end{code} %************************************************************************ @@ -54,7 +58,7 @@ See also below where we look for @DictApps@ for \tr{plusInt}, etc. dsLit :: HsLit -> DsM CoreExpr dsLit (HsChar c) = returnDs (mkCharExpr c) dsLit (HsCharPrim c) = returnDs (mkLit (MachChar c)) -dsLit (HsString str) = mkStringLitFS str +dsLit (HsString str) = mkStringExprFS str dsLit (HsStringPrim s) = returnDs (mkLit (MachStr s)) dsLit (HsInteger i _) = mkIntegerExpr i dsLit (HsInt i) = returnDs (mkIntExpr i) @@ -75,79 +79,109 @@ dsLit (HsRat r ty) %************************************************************************ %* * - Pattern matching on literals + Tidying lit pats %* * %************************************************************************ \begin{code} -matchLiterals :: [Id] - -> [EquationInfo] - -> DsM MatchResult +tidyLitPat :: HsLit -> LPat Id -> LPat Id +-- Result has only the following HsLits: +-- HsIntPrim, HsCharPrim, HsFloatPrim +-- HsDoublePrim, HsStringPrim ? +-- * HsInteger, HsRat, HsInt can't show up in LitPats, +-- * HsString has been turned into an NPat in tcPat +-- and we get rid of HsChar right here +tidyLitPat (HsChar c) pat = mkCharLitPat c +tidyLitPat lit pat = pat + +tidyNPat :: HsLit -> Type -> LPat Id -> LPat Id +tidyNPat (HsString s) _ pat + | lengthFS s <= 1 -- Short string literals only + = foldr (\c pat -> mkPrefixConPat consDataCon [mkCharLitPat c,pat] stringTy) + (mkNilPat stringTy) (unpackFS s) + -- The stringTy is the type of the whole pattern, not + -- the type to instantiate (:) or [] with! + +tidyNPat lit lit_ty default_pat + | isIntTy lit_ty = mkPrefixConPat intDataCon [noLoc $ LitPat (mk_int lit)] lit_ty + | isFloatTy lit_ty = mkPrefixConPat floatDataCon [noLoc $ LitPat (mk_float lit)] lit_ty + | isDoubleTy lit_ty = mkPrefixConPat doubleDataCon [noLoc $ LitPat (mk_double lit)] lit_ty + | otherwise = default_pat + + where + mk_int (HsInteger i _) = HsIntPrim i + + mk_float (HsInteger i _) = HsFloatPrim (fromInteger i) + mk_float (HsRat f _) = HsFloatPrim f + + mk_double (HsInteger i _) = HsDoublePrim (fromInteger i) + mk_double (HsRat f _) = HsDoublePrim f \end{code} -This first one is a {\em special case} where the literal patterns are -unboxed numbers (NB: the fiddling introduced by @tidyEqnInfo@). We -want to avoid using the ``equality'' stuff provided by the -typechecker, and do a real ``case'' instead. In that sense, the code -is much like @matchConFamily@, which uses @match_cons_used@ to create -the alts---here we use @match_prims_used@. + +%************************************************************************ +%* * + Pattern matching on LitPat +%* * +%************************************************************************ \begin{code} -matchLiterals all_vars@(var:vars) eqns_info@(EqnInfo n ctx (LitPat literal : ps1) _ : eqns) - = -- GENERATE THE ALTS - match_prims_used vars eqns_info `thenDs` \ prim_alts -> +matchLiterals :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult +-- All the EquationInfos have LitPats at the front + +matchLiterals (var:vars) ty eqns + = do { -- GROUP BY LITERAL + let groups :: [[(Literal, EquationInfo)]] + groups = equivClasses cmpTaggedEqn (tagLitEqns eqns) - -- MAKE THE PRIMITIVE CASE - returnDs (mkCoPrimCaseMatchResult var prim_alts) + -- DO THE MATCHING FOR EACH GROUP + ; alts <- mapM match_group groups + + -- MAKE THE PRIMITIVE CASE + ; return (mkCoPrimCaseMatchResult var ty alts) } where - match_prims_used _ [{-no more eqns-}] = returnDs [] - - match_prims_used vars eqns_info@(EqnInfo n ctx (pat@(LitPat literal):ps1) _ : eqns) - = let - (shifted_eqns_for_this_lit, eqns_not_for_this_lit) - = partitionEqnsByLit pat eqns_info - in - -- recursive call to make other alts... - match_prims_used vars eqns_not_for_this_lit `thenDs` \ rest_of_alts -> - - -- (prim pats have no args; no selectMatchVars as in match_cons_used) - -- now do the business to make the alt for _this_ LitPat ... - match vars shifted_eqns_for_this_lit `thenDs` \ match_result -> - returnDs ( - (mk_core_lit literal, match_result) - : rest_of_alts - ) - where - mk_core_lit :: HsLit -> Literal - - mk_core_lit (HsIntPrim i) = mkMachInt i - mk_core_lit (HsCharPrim c) = MachChar c - mk_core_lit (HsStringPrim s) = MachStr s - mk_core_lit (HsFloatPrim f) = MachFloat f - mk_core_lit (HsDoublePrim d) = MachDouble d - mk_core_lit other = panic "matchLiterals:mk_core_lit:unhandled" + match_group :: [(Literal, EquationInfo)] -> DsM (Literal, MatchResult) + match_group group + = do { let (lits, eqns) = unzip group + ; match_result <- match vars ty (shiftEqns eqns) + ; return (head lits, match_result) } \end{code} +%************************************************************************ +%* * + Pattern matching on NPat +%* * +%************************************************************************ + \begin{code} -matchLiterals all_vars@(var:vars) - eqns_info@(EqnInfo n ctx (pat@(NPatOut literal lit_ty eq_chk):ps1) _ : eqns) - = let - (shifted_eqns_for_this_lit, eqns_not_for_this_lit) - = partitionEqnsByLit pat eqns_info - in - dsExpr (HsApp (noLoc eq_chk) (nlHsVar var)) `thenDs` \ pred_expr -> - match vars shifted_eqns_for_this_lit `thenDs` \ inner_match_result -> - let - match_result1 = mkGuardedMatchResult pred_expr inner_match_result - in - if (null eqns_not_for_this_lit) - then - returnDs match_result1 - else - matchLiterals all_vars eqns_not_for_this_lit `thenDs` \ match_result2 -> - returnDs (combineMatchResults match_result1 match_result2) +matchNPats :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult +-- All the EquationInfos have NPatOut at the front + +matchNPats (var:vars) ty eqns + = do { let groups :: [[(Literal, EquationInfo)]] + groups = equivClasses cmpTaggedEqn (tagLitEqns eqns) + + ; match_results <- mapM (match_group . map snd) groups + + ; ASSERT( not (null match_results) ) + return (foldr1 combineMatchResults match_results) } + where + match_group :: [EquationInfo] -> DsM MatchResult + match_group eqns + = do { pred_expr <- dsExpr (HsApp (noLoc eq_chk) (nlHsVar var)) + ; match_result <- match vars ty (shiftEqns eqns) + ; return (mkGuardedMatchResult pred_expr match_result) } + where + NPatOut _ _ eq_chk = firstPat (head eqns) \end{code} + +%************************************************************************ +%* * + Pattern matching on n+k patterns +%* * +%************************************************************************ + For an n+k pattern, we use the various magic expressions we've been given. We generate: \begin{verbatim} @@ -158,74 +192,88 @@ We generate: <try-next-pattern-or-whatever> \end{verbatim} +WATCH OUT! Consider + + f (n+1) = ... + f (n+2) = ... + f (n+1) = ... + +We can't group the first and third together, because the second may match +the same thing as the first. Contrast + f 1 = ... + f 2 = ... + f 1 = ... +where we can group the first and third. Hence 'runs' rather than 'equivClasses' \begin{code} -matchLiterals all_vars@(var:vars) eqns_info@(EqnInfo n ctx (pat@(NPlusKPatOut master_n k ge sub):ps1) _ : eqns) - = let - (shifted_eqns_for_this_lit, eqns_not_for_this_lit) - = partitionEqnsByLit pat eqns_info - in - match vars shifted_eqns_for_this_lit `thenDs` \ inner_match_result -> - - dsExpr (HsApp (noLoc ge) (nlHsVar var)) `thenDs` \ ge_expr -> - dsExpr (HsApp (noLoc sub) (nlHsVar var)) `thenDs` \ nminusk_expr -> - - let - match_result1 = mkGuardedMatchResult ge_expr $ - mkCoLetsMatchResult [NonRec (unLoc master_n) nminusk_expr] $ - inner_match_result - in - if (null eqns_not_for_this_lit) - then - returnDs match_result1 - else - matchLiterals all_vars eqns_not_for_this_lit `thenDs` \ match_result2 -> - returnDs (combineMatchResults match_result1 match_result2) +matchNPlusKPats all_vars@(var:vars) ty eqns + = do { let groups :: [[(Literal, EquationInfo)]] + groups = runs eqTaggedEqn (tagLitEqns eqns) + + ; match_results <- mapM (match_group . map snd) groups + + ; ASSERT( not (null match_results) ) + return (foldr1 combineMatchResults match_results) } + where + match_group :: [EquationInfo] -> DsM MatchResult + match_group eqns + = do { ge_expr <- dsExpr (HsApp (noLoc ge) (nlHsVar var)) + ; minusk_expr <- dsExpr (HsApp (noLoc sub) (nlHsVar var)) + ; match_result <- match vars ty (shiftEqns eqns) + ; return (mkGuardedMatchResult ge_expr $ + mkCoLetsMatchResult [NonRec n1 minusk_expr] $ + bindInMatchResult (map line_up other_pats) $ + match_result) } + where + (NPlusKPatOut (L _ n1) _ ge sub : other_pats) = map firstPat eqns + line_up (NPlusKPatOut (L _ n) _ _ _) = (n,n1) \end{code} + +%************************************************************************ +%* * + Grouping functions +%* * +%************************************************************************ + Given a blob of @LitPat@s/@NPat@s, we want to split them into those that are ``same''/different as one we are looking at. We need to know whether we're looking at a @LitPat@/@NPat@, and what literal we're after. \begin{code} -partitionEqnsByLit :: Pat Id - -> [EquationInfo] - -> ([EquationInfo], -- These ones are for this lit, AND - -- they've been "shifted" by stripping - -- off the first pattern - [EquationInfo] -- These are not for this lit; they - -- are exactly as fed in. - ) - -partitionEqnsByLit master_pat eqns - = ( \ (xs,ys) -> (catMaybes xs, catMaybes ys)) - (unzip (map (partition_eqn master_pat) eqns)) +-- Tag equations by the leading literal +-- NB: we have ordering on Core Literals, but not on HsLits +cmpTaggedEqn :: (Literal,EquationInfo) -> (Literal,EquationInfo) -> Ordering +cmpTaggedEqn (lit1,_) (lit2,_) = lit1 `compare` lit2 + +eqTaggedEqn :: (Literal,EquationInfo) -> (Literal,EquationInfo) -> Bool +eqTaggedEqn (lit1,_) (lit2,_) = lit1 == lit2 + +tagLitEqns :: [EquationInfo] -> [(Literal, EquationInfo)] +tagLitEqns eqns + = [(get_lit eqn, eqn) | eqn <- eqns] where - partition_eqn :: Pat Id -> EquationInfo -> (Maybe EquationInfo, Maybe EquationInfo) - - partition_eqn (LitPat k1) (EqnInfo n ctx (LitPat k2 : remaining_pats) match_result) - | k1 == k2 = (Just (EqnInfo n ctx remaining_pats match_result), Nothing) - -- NB the pattern is stripped off the EquationInfo - - partition_eqn (NPatOut k1 _ _) (EqnInfo n ctx (NPatOut k2 _ _ : remaining_pats) match_result) - | k1 == k2 = (Just (EqnInfo n ctx remaining_pats match_result), Nothing) - -- NB the pattern is stripped off the EquationInfo - - partition_eqn (NPlusKPatOut (L _ master_n) k1 _ _) - (EqnInfo n ctx (NPlusKPatOut (L _ n') k2 _ _ : remaining_pats) match_result) - | k1 == k2 = (Just (EqnInfo n ctx remaining_pats new_match_result), Nothing) - -- NB the pattern is stripped off the EquationInfo - where - new_match_result | master_n == n' = match_result - | otherwise = mkCoLetsMatchResult - [NonRec n' (Var master_n)] match_result - - -- Wild-card patterns, which will only show up in the shadows, - -- go into both groups - partition_eqn master_pat eqn@(EqnInfo n ctx (WildPat _ : remaining_pats) match_result) - = (Just (EqnInfo n ctx remaining_pats match_result), Just eqn) - - -- Default case; not for this pattern - partition_eqn master_pat eqn = (Nothing, Just eqn) + get_lit eqn = case firstPat eqn of + LitPat hs_lit -> mk_core_lit hs_lit + NPatOut hs_lit _ _ -> mk_core_lit hs_lit + NPlusKPatOut _ i _ _ -> MachInt i + other -> panic "tagLitEqns:bad pattern" + +mk_core_lit :: HsLit -> Literal +mk_core_lit (HsIntPrim i) = mkMachInt i +mk_core_lit (HsCharPrim c) = MachChar c +mk_core_lit (HsStringPrim s) = MachStr s +mk_core_lit (HsFloatPrim f) = MachFloat f +mk_core_lit (HsDoublePrim d) = MachDouble d + + -- These ones are only needed in the NPatOut case, + -- and the Literal is only used as a key for grouping, + -- so the type doesn't matter. Actually I think HsInt, HsChar + -- can't happen, but it does no harm to include them +mk_core_lit (HsString s) = MachStr s +mk_core_lit (HsRat r _) = MachFloat r +mk_core_lit (HsInteger i _) = MachInt i +mk_core_lit (HsInt i) = MachInt i +mk_core_lit (HsChar c) = MachChar c \end{code} diff --git a/ghc/compiler/ghci/ByteCodeGen.lhs b/ghc/compiler/ghci/ByteCodeGen.lhs index 2c9db61226..59648849e0 100644 --- a/ghc/compiler/ghci/ByteCodeGen.lhs +++ b/ghc/compiler/ghci/ByteCodeGen.lhs @@ -28,7 +28,7 @@ import PrimOp ( PrimOp(..) ) import CoreFVs ( freeVars ) import Type ( isUnLiftedType, splitTyConApp_maybe ) import DataCon ( DataCon, dataConTag, fIRST_TAG, dataConTyCon, - isUnboxedTupleCon, isNullaryDataCon, dataConWorkId, + isUnboxedTupleCon, isNullaryRepDataCon, dataConWorkId, dataConRepArity ) import TyCon ( tyConFamilySize, isDataTyCon, tyConDataCons, isUnboxedTupleTyCon ) @@ -210,7 +210,7 @@ schemeTopBind :: (Id, AnnExpr Id VarSet) -> BcM (ProtoBCO Name) schemeTopBind (id, rhs) | Just data_con <- isDataConWorkId_maybe id, - isNullaryDataCon data_con + isNullaryRepDataCon data_con = -- Special case for the worker of a nullary data con. -- It'll look like this: Nil = /\a -> Nil a -- If we feed it into schemeR, we'll get @@ -391,7 +391,7 @@ schemeE d s p (AnnLet binds (_,body)) -schemeE d s p (AnnCase scrut bndr [(DataAlt dc, [bind1, bind2], rhs)]) +schemeE d s p (AnnCase scrut bndr _ [(DataAlt dc, [bind1, bind2], rhs)]) | isUnboxedTupleCon dc, VoidArg <- typeCgRep (idType bind1) -- Convert -- case .... of x { (# VoidArg'd-thing, a #) -> ... } @@ -409,7 +409,7 @@ schemeE d s p (AnnCase scrut bndr [(DataAlt dc, [bind1, bind2], rhs)]) = --trace "automagic mashing of case alts (# a, VoidArg #)" $ doCase d s p scrut bind1 [(DEFAULT, [], rhs)] True{-unboxed tuple-} -schemeE d s p (AnnCase scrut bndr [(DataAlt dc, [bind1], rhs)]) +schemeE d s p (AnnCase scrut bndr _ [(DataAlt dc, [bind1], rhs)]) | isUnboxedTupleCon dc -- Similarly, convert -- case .... of x { (# a #) -> ... } @@ -418,7 +418,7 @@ schemeE d s p (AnnCase scrut bndr [(DataAlt dc, [bind1], rhs)]) = --trace "automagic mashing of case alts (# a #)" $ doCase d s p scrut bind1 [(DEFAULT, [], rhs)] True{-unboxed tuple-} -schemeE d s p (AnnCase scrut bndr alts) +schemeE d s p (AnnCase scrut bndr _ alts) = doCase d s p scrut bndr alts False{-not an unboxed tuple-} schemeE d s p (AnnNote note (_, body)) @@ -541,7 +541,7 @@ mkConAppCode :: Int -> Sequel -> BCEnv -> BcM BCInstrList mkConAppCode orig_d s p con [] -- Nullary constructor - = ASSERT( isNullaryDataCon con ) + = ASSERT( isNullaryRepDataCon con ) returnBc (unitOL (PUSH_G (getName (dataConWorkId con)))) -- Instead of doing a PACK, which would allocate a fresh -- copy of this constructor, use the single shared version. @@ -591,9 +591,9 @@ doTailCall init_d s p fn args = do_pushes init_d args (map atomRep args) where do_pushes d [] reps = do - ASSERTM( null reps ) + ASSERT( null reps ) return () (push_fn, sz) <- pushAtom d p (AnnVar fn) - ASSERTM( sz == 1 ) + ASSERT( sz == 1 ) return () returnBc (push_fn `appOL` ( mkSLIDE ((d-init_d) + 1) (init_d - s) `appOL` unitOL ENTER)) diff --git a/ghc/compiler/ghci/InteractiveUI.hs b/ghc/compiler/ghci/InteractiveUI.hs index 98b653d912..1648773984 100644 --- a/ghc/compiler/ghci/InteractiveUI.hs +++ b/ghc/compiler/ghci/InteractiveUI.hs @@ -1,6 +1,6 @@ {-# OPTIONS -#include "Linker.h" #-} ----------------------------------------------------------------------------- --- $Id: InteractiveUI.hs,v 1.175 2004/08/20 15:02:40 simonmar Exp $ +-- $Id: InteractiveUI.hs,v 1.176 2004/09/30 10:36:47 simonpj Exp $ -- -- GHC Interactive User Interface -- @@ -532,17 +532,28 @@ showDecl want_name (IfaceSyn {ifName = tycon, ifTyVars = tyvars, ifSynRhs = mono = hang (ptext SLIT("type") <+> pprIfaceDeclHead [] tycon tyvars) 2 (equals <+> ppr mono_ty) -showDecl want_name (IfaceData {ifCtxt = context, ifName = tycon, +showDecl want_name (IfaceData {ifName = tycon, ifTyVars = tyvars, ifCons = condecls}) = hang (pp_nd <+> pprIfaceDeclHead context tycon tyvars) 2 (add_bars (ppr_trim show_con cs)) where - show_con (IfaceConDecl con_name is_infix ex_tvs ex_cxt tys strs flds) + show_con (IfVanillaCon { ifConOcc = con_name, ifConInfix = is_infix, ifConArgTys = tys, + ifConStricts = strs, ifConFields = flds}) | want_name tycon || want_name con_name || any want_name flds - = Just (pprIfaceForAllPart ex_tvs ex_cxt (show_guts con_name is_infix tys_w_strs flds)) + = Just (show_guts con_name is_infix tys_w_strs flds) | otherwise = Nothing where tys_w_strs = tys `zip` (strs ++ repeat NotMarkedStrict) + show_con (IfGadtCon { ifConOcc = con_name, ifConTyVars = tvs, ifConCtxt = theta, + ifConArgTys = arg_tys, ifConResTys = res_tys, ifConStricts = strs }) + | want_name tycon || want_name con_name + = Just (ppr_bndr con_name <+> colon <+> pprIfaceForAllPart tvs theta pp_tau) + | otherwise = Nothing + where + tys_w_strs = arg_tys `zip` (strs ++ repeat NotMarkedStrict) + pp_tau = foldr add pp_res_ty tys_w_strs + pp_res_ty = ppr_bndr tycon <+> hsep (map pprParendIfaceType res_tys) + add bty pp_ty = ppr_bangty bty <+> arrow <+> pp_ty show_guts con True [ty1, ty2] flds = sep [ppr_bangty ty1, ppr con, ppr_bangty ty2] show_guts con _ tys [] = ppr_bndr con <+> sep (map ppr_bangty tys) @@ -553,10 +564,11 @@ showDecl want_name (IfaceData {ifCtxt = context, ifName = tycon, = Just (ppr_bndr fld <+> dcolon <+> ppr_bangty bty) | otherwise = Nothing - (pp_nd, cs) = case condecls of - IfAbstractTyCon -> (ptext SLIT("data"), []) - IfDataTyCon cs -> (ptext SLIT("data"), cs) - IfNewTyCon c -> (ptext SLIT("newtype"), [c]) + (pp_nd, context, cs) = case condecls of + IfAbstractTyCon -> (ptext SLIT("data"), [], []) + IfDataTyCon (Just cxt) cs -> (ptext SLIT("data"), cxt, cs) + IfDataTyCon Nothing cs -> (ptext SLIT("data"), [], cs) + IfNewTyCon c -> (ptext SLIT("newtype"), [], [c]) add_bars [] = empty add_bars [c] = equals <+> c diff --git a/ghc/compiler/hsSyn/Convert.lhs b/ghc/compiler/hsSyn/Convert.lhs index 2d7c85add9..e709d4d9a9 100644 --- a/ghc/compiler/hsSyn/Convert.lhs +++ b/ghc/compiler/hsSyn/Convert.lhs @@ -53,13 +53,13 @@ mk_con con = L loc0 $ case con of -> ConDecl (noLoc (cName c)) noExistentials noContext (InfixCon (mk_arg st1) (mk_arg st2)) where - mk_arg (IsStrict, ty) = noLoc $ BangType HsStrict (cvtType ty) - mk_arg (NotStrict, ty) = noLoc $ BangType HsNoBang (cvtType ty) + mk_arg (IsStrict, ty) = noLoc $ HsBangTy HsStrict (cvtType ty) + mk_arg (NotStrict, ty) = noLoc $ HsBangTy HsNoBang (cvtType ty) mk_id_arg (i, IsStrict, ty) - = (noLoc (vName i), noLoc $ BangType HsStrict (cvtType ty)) + = (noLoc (vName i), noLoc $ HsBangTy HsStrict (cvtType ty)) mk_id_arg (i, NotStrict, ty) - = (noLoc (vName i), noLoc $ BangType HsNoBang (cvtType ty)) + = (noLoc (vName i), noLoc $ HsBangTy HsNoBang (cvtType ty)) mk_derivs [] = Nothing mk_derivs cs = Just [noLoc $ HsPredTy $ HsClassP (tconName c) [] | c <- cs] @@ -183,12 +183,12 @@ cvt (LitE l) | otherwise = HsLit (cvtLit l) cvt (AppE x y) = HsApp (cvtl x) (cvtl y) -cvt (LamE ps e) = HsLam (mkSimpleMatch (map cvtlp ps) (cvtl e) void) +cvt (LamE ps e) = HsLam (mkMatchGroup [mkSimpleMatch (map cvtlp ps) (cvtl e)]) cvt (TupE [e]) = cvt e cvt (TupE es) = ExplicitTuple(map cvtl es) Boxed cvt (CondE x y z) = HsIf (cvtl x) (cvtl y) (cvtl z) cvt (LetE ds e) = HsLet (cvtdecs ds) (cvtl e) -cvt (CaseE e ms) = HsCase (cvtl e) (map cvtm ms) +cvt (CaseE e ms) = HsCase (cvtl e) (mkMatchGroup (map cvtm ms)) cvt (DoE ss) = HsDo DoExpr (cvtstmts ss) [] void cvt (CompE ss) = HsDo ListComp (cvtstmts ss) [] void cvt (ArithSeqE dd) = ArithSeqIn (cvtdd dd) @@ -223,11 +223,11 @@ cvtd :: TH.Dec -> LHsBind RdrName -- Used only for declarations in a 'let/where' clause, -- not for top level decls cvtd (TH.ValD (TH.VarP s) body ds) - = noLoc $ FunBind (noLoc (vName s)) False [cvtclause (Clause [] body ds)] + = noLoc $ FunBind (noLoc (vName s)) False (mkMatchGroup [cvtclause (Clause [] body ds)]) cvtd (FunD nm cls) - = noLoc $ FunBind (noLoc (vName nm)) False (map cvtclause cls) + = noLoc $ FunBind (noLoc (vName nm)) False (mkMatchGroup (map cvtclause cls)) cvtd (TH.ValD p body ds) - = noLoc $ PatBind (cvtlp p) (GRHSs (cvtguard body) (cvtdecs ds) void) + = noLoc $ PatBind (cvtlp p) (GRHSs (cvtguard body) (cvtdecs ds)) void cvtd d = cvtPanic "Illegal kind of declaration in where clause" (text (TH.pprint d)) @@ -235,7 +235,7 @@ cvtd d = cvtPanic "Illegal kind of declaration in where clause" cvtclause :: TH.Clause -> Hs.LMatch RdrName cvtclause (Clause ps body wheres) - = noLoc $ Hs.Match (map cvtlp ps) Nothing (GRHSs (cvtguard body) (cvtdecs wheres) void) + = noLoc $ Hs.Match (map cvtlp ps) Nothing (GRHSs (cvtguard body) (cvtdecs wheres)) @@ -256,7 +256,7 @@ cvtstmts (TH.ParS dss : ss) = nlParStmt [(cvtstmts ds, undefined) | ds <- dss] cvtm :: TH.Match -> Hs.LMatch RdrName cvtm (TH.Match p body wheres) - = noLoc (Hs.Match [cvtlp p] Nothing (GRHSs (cvtguard body) (cvtdecs wheres) void)) + = noLoc (Hs.Match [cvtlp p] Nothing (GRHSs (cvtguard body) (cvtdecs wheres))) cvtguard :: TH.Body -> [LGRHS RdrName] cvtguard (GuardedB pairs) = map cvtpair pairs diff --git a/ghc/compiler/hsSyn/HsBinds.lhs b/ghc/compiler/hsSyn/HsBinds.lhs index c473fd3c6e..e3485b9478 100644 --- a/ghc/compiler/hsSyn/HsBinds.lhs +++ b/ghc/compiler/hsSyn/HsBinds.lhs @@ -11,21 +11,18 @@ module HsBinds where #include "HsVersions.h" import {-# SOURCE #-} HsExpr ( HsExpr, pprExpr, LHsExpr, - LMatch, pprFunBind, + MatchGroup, pprFunBind, GRHSs, pprPatBind ) +import {-# SOURCE #-} HsPat ( LPat ) --- friends: -import HsPat ( LPat ) -import HsTypes ( LHsType ) - ---others: +import HsTypes ( LHsType, PostTcType ) import Name ( Name ) import NameSet ( NameSet, elemNameSet, nameSetToList ) import BasicTypes ( IPName, RecFlag(..), Activation(..), Fixity ) import Outputable import SrcLoc ( Located(..), unLoc ) import Var ( TyVar ) -import Bag ( Bag, bagToList ) +import Bag ( Bag, emptyBag, isEmptyBag, bagToList ) \end{code} %************************************************************************ @@ -81,11 +78,20 @@ instance (OutputableBndr id) => Outputable (IPBind id) where -- ----------------------------------------------------------------------------- -type LHsBinds id = Bag (LHsBind id) -type LHsBind id = Located (HsBind id) +type LHsBinds id = Bag (LHsBind id) +type DictBinds id = LHsBinds id -- Used for dictionary or method bindings +type LHsBind id = Located (HsBind id) + +emptyLHsBinds :: LHsBinds id +emptyLHsBinds = emptyBag + +isEmptyLHsBinds :: LHsBinds id -> Bool +isEmptyLHsBinds = isEmptyBag pprLHsBinds :: OutputableBndr id => LHsBinds id -> SDoc -pprLHsBinds binds = lbrace <+> vcat (map ppr (bagToList binds)) <+> rbrace +pprLHsBinds binds + | isEmptyLHsBinds binds = empty + | otherwise = lbrace <+> vcat (map ppr (bagToList binds)) <+> rbrace data HsBind id = FunBind (Located id) @@ -98,11 +104,12 @@ data HsBind id -- FunBinds, so if you change this, you'll need to -- change e.g. rnMethodBinds Bool -- True => infix declaration - [LMatch id] + (MatchGroup id) | PatBind (LPat id) -- The pattern is never a simple variable; -- That case is done by FunBind (GRHSs id) + PostTcType -- Type of the GRHSs | VarBind id (Located (HsExpr id)) -- Dictionary binding and suchlike; -- located only for consistency @@ -152,7 +159,7 @@ instance OutputableBndr id => Outputable (HsBind id) where ppr_monobind :: OutputableBndr id => HsBind id -> SDoc -ppr_monobind (PatBind pat grhss) = pprPatBind pat grhss +ppr_monobind (PatBind pat grhss ty) = pprPatBind pat grhss ppr_monobind (VarBind var rhs) = ppr var <+> equals <+> pprExpr (unLoc rhs) ppr_monobind (FunBind fun inf matches) = pprFunBind (unLoc fun) matches -- ToDo: print infix if appropriate diff --git a/ghc/compiler/hsSyn/HsDecls.lhs b/ghc/compiler/hsSyn/HsDecls.lhs index 3a610024a3..4b1b028a78 100644 --- a/ghc/compiler/hsSyn/HsDecls.lhs +++ b/ghc/compiler/hsSyn/HsDecls.lhs @@ -14,9 +14,7 @@ module HsDecls ( DefaultDecl(..), LDefaultDecl, HsGroup(..), SpliceDecl(..), ForeignDecl(..), LForeignDecl, ForeignImport(..), ForeignExport(..), CImportSpec(..), FoType(..), - ConDecl(..), LConDecl, - LBangType, BangType(..), HsBang(..), - getBangType, getBangStrictness, unbangedType, + ConDecl(..), LConDecl, DeprecDecl(..), LDeprecDecl, tcdName, tyClDeclNames, tyClDeclTyVars, isClassDecl, isSynDecl, isDataDecl, @@ -429,7 +427,10 @@ pp_decl_head :: OutputableBndr name pp_decl_head context thing tyvars = hsep [pprHsContext context, ppr thing, interppSP tyvars] -pp_condecls cs = equals <+> sep (punctuate (ptext SLIT(" |")) (map ppr cs)) +pp_condecls cs@(L _ (GadtDecl _ _) : _) -- In GADT syntax + = hang (ptext SLIT("where")) 2 (vcat (map ppr cs)) +pp_condecls cs -- In H98 syntax + = equals <+> sep (punctuate (ptext SLIT(" |")) (map ppr cs)) pp_tydecl pp_head pp_decl_rhs derivings = hang pp_head 4 (sep [ @@ -461,8 +462,12 @@ data ConDecl name [LHsTyVarBndr name] -- Existentially quantified type variables (LHsContext name) -- ...and context -- If both are empty then there are no existentials - (HsConDetails name (LBangType name)) + + | GadtDecl (Located name) -- Constructor name; this is used for the + -- DataCon itself, and for the user-callable wrapper Id + (LHsType name) -- Constructor type; it may have HsBangs on the + -- argument types \end{code} \begin{code} @@ -481,32 +486,23 @@ conDeclsNames cons do_one (flds_seen, acc) (ConDecl lname _ _ _) = (flds_seen, lname:acc) +-- gaw 2004 + do_one (flds_seen, acc) (GadtDecl lname _) + = (flds_seen, lname:acc) + conDetailsTys details = map getBangType (hsConArgs details) \end{code} -\begin{code} -type LBangType name = Located (BangType name) - -data BangType name = BangType HsBang (LHsType name) - -data HsBang = HsNoBang - | HsStrict -- ! - | HsUnbox -- {-# UNPACK #-} ! (GHC extension, meaning "unbox") - -getBangType (BangType _ ty) = ty -getBangStrictness (BangType s _) = s - -unbangedType :: LHsType id -> LBangType id -unbangedType ty@(L loc _) = L loc (BangType HsNoBang ty) -\end{code} \begin{code} instance (OutputableBndr name) => Outputable (ConDecl name) where ppr (ConDecl con tvs cxt con_details) = sep [pprHsForAll Explicit tvs cxt, ppr_con_details con con_details] + ppr (GadtDecl con ty) + = ppr con <+> dcolon <+> ppr ty ppr_con_details con (InfixCon ty1 ty2) - = hsep [ppr ty1, ppr con, ppr ty2] + = hsep [ppr ty1, pprHsVar con, ppr ty2] -- ConDecls generated by MkIface.ifaceTyThing always have a PrefixCon, even -- if the constructor is an infix one. This is because in an interface file @@ -520,17 +516,8 @@ ppr_con_details con (RecCon fields) where ppr_field (n, ty) = ppr n <+> dcolon <+> ppr ty -instance OutputableBndr name => Outputable (BangType name) where - ppr (BangType is_strict ty) - = bang <> pprParendHsType (unLoc ty) - where - bang = case is_strict of - HsNoBang -> empty - HsStrict -> char '!' - HsUnbox -> ptext SLIT("!!") \end{code} - %************************************************************************ %* * \subsection[InstDecl]{An instance declaration diff --git a/ghc/compiler/hsSyn/HsExpr.hi-boot-6 b/ghc/compiler/hsSyn/HsExpr.hi-boot-6 index 30d90a0628..dd12cd5537 100644 --- a/ghc/compiler/hsSyn/HsExpr.hi-boot-6 +++ b/ghc/compiler/hsSyn/HsExpr.hi-boot-6 @@ -2,11 +2,10 @@ module HsExpr where data HsExpr i data HsSplice i -data Match a +data MatchGroup a data GRHSs a type LHsExpr a = SrcLoc.Located (HsExpr a) -type LMatch a = SrcLoc.Located (Match a) pprExpr :: (Outputable.OutputableBndr i) => HsExpr.HsExpr i -> Outputable.SDoc @@ -14,8 +13,8 @@ pprExpr :: (Outputable.OutputableBndr i) => pprSplice :: (Outputable.OutputableBndr i) => HsExpr.HsSplice i -> Outputable.SDoc -pprPatBind :: (Outputable.OutputableBndr i) => - HsPat.LPat i -> HsExpr.GRHSs i -> Outputable.SDoc +pprPatBind :: (Outputable.OutputableBndr b, Outputable.OutputableBndr i) => + HsPat.LPat b -> HsExpr.GRHSs i -> Outputable.SDoc pprFunBind :: (Outputable.OutputableBndr i) => - i -> [HsExpr.LMatch i] -> Outputable.SDoc + i -> HsExpr.MatchGroup i -> Outputable.SDoc diff --git a/ghc/compiler/hsSyn/HsExpr.lhs b/ghc/compiler/hsSyn/HsExpr.lhs index 88b681c8a0..e529e6fea4 100644 --- a/ghc/compiler/hsSyn/HsExpr.lhs +++ b/ghc/compiler/hsSyn/HsExpr.lhs @@ -43,8 +43,9 @@ data HsExpr id | HsOverLit HsOverLit -- Overloaded literals; eliminated by type checker | HsLit HsLit -- Simple (non-overloaded) literals - | HsLam (LMatch id) -- lambda - | HsApp (LHsExpr id) -- application + | HsLam (MatchGroup id) -- Currently always a single match + + | HsApp (LHsExpr id) -- Application (LHsExpr id) -- Operator applications: @@ -72,7 +73,7 @@ data HsExpr id (LHsExpr id) -- operand | HsCase (LHsExpr id) - [LMatch id] + (MatchGroup id) | HsIf (LHsExpr id) -- predicate (LHsExpr id) -- then part @@ -267,8 +268,6 @@ ppr_expr (HsIPVar v) = ppr v ppr_expr (HsLit lit) = ppr lit ppr_expr (HsOverLit lit) = ppr lit -ppr_expr (HsLam match) = pprMatch LambdaExpr (unLoc match) - ppr_expr (HsApp e1 e2) = let (fun, args) = collect_args e1 [e2] in (ppr_lexpr fun) <+> (sep (map pprParendExpr args)) @@ -317,6 +316,9 @@ ppr_expr (SectionR op expr) pp_infixly v = parens (sep [ppr v, pp_expr]) +ppr_expr (HsLam matches) + = pprMatches LambdaExpr matches + ppr_expr (HsCase expr matches) = sep [ sep [ptext SLIT("case"), nest 4 (ppr expr), ptext SLIT("of")], nest 2 (pprMatches CaseAlt matches) ] @@ -590,6 +592,13 @@ a function defined by pattern matching must have the same number of patterns in each equation. \begin{code} +data MatchGroup id + = MatchGroup + [LMatch id] -- The alternatives + PostTcType -- The type is the type of the entire group + -- t1 -> ... -> tn -> tr + -- where there are n patterns + type LMatch id = Located (Match id) data Match id @@ -597,14 +606,18 @@ data Match id [LPat id] -- The patterns (Maybe (LHsType id)) -- A type signature for the result of the match -- Nothing after typechecking - (GRHSs id) +-- gaw 2004 +hsLMatchPats :: LMatch id -> [LPat id] +hsLMatchPats (L _ (Match pats _ _)) = pats + -- GRHSs are used both for pattern bindings and for Matches data GRHSs id = GRHSs [LGRHS id] -- Guarded RHSs [HsBindGroup id] -- The where clause - PostTcType -- Type of RHS (after type checking) +-- gaw 2004 +-- PostTcType -- Type of RHS (after type checking) type LGRHS id = Located (GRHS id) @@ -615,23 +628,24 @@ data GRHS id We know the list must have at least one @Match@ in it. \begin{code} -pprMatches :: (OutputableBndr id) => HsMatchContext id -> [LMatch id] -> SDoc -pprMatches ctxt matches = vcat (map (pprMatch ctxt) (map unLoc matches)) +pprMatches :: (OutputableBndr id) => HsMatchContext id -> MatchGroup id -> SDoc +pprMatches ctxt (MatchGroup matches _) = vcat (map (pprMatch ctxt) (map unLoc matches)) -- Exported to HsBinds, which can't see the defn of HsMatchContext -pprFunBind :: (OutputableBndr id) => id -> [LMatch id] -> SDoc +pprFunBind :: (OutputableBndr id) => id -> MatchGroup id -> SDoc pprFunBind fun matches = pprMatches (FunRhs fun) matches -- Exported to HsBinds, which can't see the defn of HsMatchContext -pprPatBind :: (OutputableBndr id) - => LPat id -> GRHSs id -> SDoc +pprPatBind :: (OutputableBndr bndr, OutputableBndr id) + => LPat bndr -> GRHSs id -> SDoc pprPatBind pat grhss = sep [ppr pat, nest 4 (pprGRHSs PatBindRhs grhss)] pprMatch :: OutputableBndr id => HsMatchContext id -> Match id -> SDoc +-- gaw 2004 pprMatch ctxt (Match pats maybe_ty grhss) = pp_name ctxt <+> sep [sep (map ppr pats), - ppr_maybe_ty, + ppr_maybe_ty, nest 2 (pprGRHSs ctxt grhss)] where pp_name (FunRhs fun) = ppr fun -- Not pprBndr; the AbsBinds will @@ -645,7 +659,8 @@ pprMatch ctxt (Match pats maybe_ty grhss) pprGRHSs :: OutputableBndr id => HsMatchContext id -> GRHSs id -> SDoc -pprGRHSs ctxt (GRHSs grhss binds ty) +-- gaw 2004 +pprGRHSs ctxt (GRHSs grhss binds) = vcat (map (pprGRHS ctxt . unLoc) grhss) $$ (if null binds then empty diff --git a/ghc/compiler/hsSyn/HsPat.lhs b/ghc/compiler/hsSyn/HsPat.lhs index c136ac360f..82ab6e30dd 100644 --- a/ghc/compiler/hsSyn/HsPat.lhs +++ b/ghc/compiler/hsSyn/HsPat.lhs @@ -9,14 +9,11 @@ module HsPat ( HsConDetails(..), hsConArgs, - mkPrefixConPat, mkCharLitPat, mkNilPat, + mkPrefixConPat, mkCharLitPat, mkNilPat, isWildPat, patsAreAllCons, isConPat, isSigPat, - patsAreAllLits, isLitPat, - collectPatBinders, collectPatsBinders, - collectLocatedPatBinders, collectLocatedPatsBinders, - collectSigTysFromPat, collectSigTysFromPats + patsAreAllLits, isLitPat ) where #include "HsVersions.h" @@ -25,10 +22,12 @@ module HsPat ( import {-# SOURCE #-} HsExpr ( HsExpr ) -- friends: +import HsBinds ( DictBinds, emptyLHsBinds, pprLHsBinds ) import HsLit ( HsLit(HsCharPrim), HsOverLit ) import HsTypes ( LHsType, SyntaxName, PostTcType ) import BasicTypes ( Boxity, tupleParens ) -- others: +import PprCore ( {- instance OutputableBndr TyVar -} ) import TysWiredIn ( nilDataCon, charDataCon, charTy ) import Var ( TyVar ) import DataCon ( DataCon ) @@ -48,6 +47,8 @@ data Pat id = ------------ Simple patterns --------------- WildPat PostTcType -- Wild card | VarPat id -- Variable + | VarPatOut id (DictBinds id) -- Used only for overloaded Ids; the + -- bindings give its overloaded instances | LazyPat (LPat id) -- Lazy pattern | AsPat (Located id) (LPat id) -- As pattern | ParPat (LPat id) -- Parenthesised pattern @@ -67,10 +68,11 @@ data Pat id (HsConDetails id (LPat id)) | ConPatOut DataCon - (HsConDetails id (LPat id)) - Type -- The type of the pattern [TyVar] -- Existentially bound type variables [id] -- Ditto dictionaries + (DictBinds id) -- Bindings involving those dictionaries + (HsConDetails id (LPat id)) + Type -- The type of the pattern ------------ Literal and n+k patterns --------------- | LitPat HsLit -- Used for *non-overloaded* literal patterns: @@ -84,7 +86,6 @@ data Pat id -- The literal is retained so that the desugarer can readily identify -- equations with identical literal-patterns -- Always HsInteger, HsRat or HsString. - -- Always HsInteger, HsRat or HsString. -- *Unlike* NPatIn, for negative literals, the -- literal is acutally negative! Type -- Type of pattern, t @@ -110,10 +111,8 @@ data Pat id | SigPatIn (LPat id) -- Pattern with a type signature (LHsType id) - | SigPatOut (LPat id) -- Pattern p - Type -- Type, t, of the whole pattern - (HsExpr id) -- Coercion function, - -- of type t -> typeof(p) + | SigPatOut (LPat id) -- Pattern with a type signature + Type ------------ Dictionary patterns (translation only) --------------- | DictPat -- Used when destructing Dictionaries with an explicit case @@ -146,9 +145,8 @@ hsConArgs (InfixCon p1 p2) = [p1,p2] instance (OutputableBndr name) => Outputable (Pat name) where ppr = pprPat -pprPat :: (OutputableBndr name) => Pat name -> SDoc - -pprPat (VarPat var) -- Print with type info if -dppr-debug is on +pprPatBndr :: OutputableBndr name => name -> SDoc +pprPatBndr var -- Print with type info if -dppr-debug is on = getPprStyle $ \ sty -> if debugStyle sty then parens (pprBndr LambdaBind var) -- Could pass the site to pprPat @@ -156,6 +154,10 @@ pprPat (VarPat var) -- Print with type info if -dppr-debug is on else ppr var +pprPat :: (OutputableBndr name) => Pat name -> SDoc + +pprPat (VarPat var) = pprPatBndr var +pprPat (VarPatOut var bs) = parens (pprPatBndr var <+> braces (ppr bs)) pprPat (WildPat _) = char '_' pprPat (LazyPat pat) = char '~' <> ppr pat pprPat (AsPat name pat) = parens (hcat [ppr name, char '@', ppr pat]) @@ -165,35 +167,35 @@ pprPat (ListPat pats _) = brackets (interpp'SP pats) pprPat (PArrPat pats _) = pabrackets (interpp'SP pats) pprPat (TuplePat pats bx) = tupleParens bx (interpp'SP pats) -pprPat (ConPatIn c details) = pprConPat c details -pprPat (ConPatOut c details _ _ _) = pprConPat c details +pprPat (ConPatIn con details) = pprUserCon con details +pprPat (ConPatOut con tvs dicts binds details _) + = getPprStyle $ \ sty -> -- Tiresome; in TcBinds.tcRhs we print out a + if debugStyle sty then -- typechecked Pat in an error message, + -- and we want to make sure it prints nicely + ppr con <+> sep [ hsep (map pprPatBndr tvs) <+> hsep (map pprPatBndr dicts), + pprLHsBinds binds, pprConArgs details] + else pprUserCon con details pprPat (LitPat s) = ppr s pprPat (NPatIn l _) = ppr l pprPat (NPatOut l _ _) = ppr l pprPat (NPlusKPatIn n k _) = hcat [ppr n, char '+', ppr k] pprPat (NPlusKPatOut n k _ _) = hcat [ppr n, char '+', integer k] +pprPat (TypePat ty) = ptext SLIT("{|") <> ppr ty <> ptext SLIT("|}") +pprPat (SigPatIn pat ty) = ppr pat <+> dcolon <+> ppr ty +pprPat (SigPatOut pat ty) = ppr pat <+> dcolon <+> ppr ty +pprPat (DictPat ds ms) = parens (sep [ptext SLIT("{-dict-}"), + brackets (interpp'SP ds), + brackets (interpp'SP ms)]) -pprPat (TypePat ty) = ptext SLIT("{|") <> ppr ty <> ptext SLIT("|}") - -pprPat (SigPatIn pat ty) = ppr pat <+> dcolon <+> ppr ty -pprPat (SigPatOut pat ty _) = ppr pat <+> dcolon <+> ppr ty +pprUserCon c (InfixCon p1 p2) = ppr p1 <+> ppr c <+> ppr p2 +pprUserCon c details = ppr c <+> pprConArgs details -pprPat (DictPat dicts methods) - = parens (sep [ptext SLIT("{-dict-}"), - brackets (interpp'SP dicts), - brackets (interpp'SP methods)]) - - - -pprConPat con (PrefixCon pats) = ppr con <+> interppSP pats -- inner ParPats supply the necessary parens. -pprConPat con (InfixCon pat1 pat2) = hsep [ppr pat1, ppr con, ppr pat2] -- ParPats put in parens - -- ToDo: use pprSym to print op (but this involves fiddling various - -- contexts & I'm lazy...); *PatIns are *rarely* printed anyway... (WDP) -pprConPat con (RecCon rpats) - = ppr con <+> braces (hsep (punctuate comma (map (pp_rpat) rpats))) - where - pp_rpat (v, p) = hsep [ppr v, char '=', ppr p] +pprConArgs (PrefixCon pats) = interppSP pats +pprConArgs (InfixCon p1 p2) = interppSP [p1,p2] +pprConArgs (RecCon rpats) = braces (hsep (punctuate comma (map (pp_rpat) rpats))) + where + pp_rpat (v, p) = hsep [ppr v, char '=', ppr p] -- add parallel array brackets around a document @@ -212,7 +214,7 @@ pabrackets p = ptext SLIT("[:") <> p <> ptext SLIT(":]") \begin{code} mkPrefixConPat :: DataCon -> [OutPat id] -> Type -> OutPat id -- Make a vanilla Prefix constructor pattern -mkPrefixConPat dc pats ty = noLoc $ ConPatOut dc (PrefixCon pats) ty [] [] +mkPrefixConPat dc pats ty = noLoc $ ConPatOut dc [] [] emptyLHsBinds (PrefixCon pats) ty mkNilPat :: Type -> OutPat id mkNilPat ty = mkPrefixConPat nilDataCon [] ty @@ -258,18 +260,18 @@ isWildPat other = False patsAreAllCons :: [Pat id] -> Bool patsAreAllCons pat_list = all isConPat pat_list -isConPat (AsPat _ pat) = isConPat (unLoc pat) -isConPat (ConPatIn _ _) = True -isConPat (ConPatOut _ _ _ _ _) = True -isConPat (ListPat _ _) = True -isConPat (PArrPat _ _) = True -isConPat (TuplePat _ _) = True -isConPat (DictPat ds ms) = (length ds + length ms) > 1 -isConPat other = False +isConPat (AsPat _ pat) = isConPat (unLoc pat) +isConPat (ConPatIn _ _) = True +isConPat (ConPatOut _ _ _ _ _ _) = True +isConPat (ListPat _ _) = True +isConPat (PArrPat _ _) = True +isConPat (TuplePat _ _) = True +isConPat (DictPat ds ms) = (length ds + length ms) > 1 +isConPat other = False -isSigPat (SigPatIn _ _) = True -isSigPat (SigPatOut _ _ _) = True -isSigPat other = False +isSigPat (SigPatIn _ _) = True +isSigPat (SigPatOut _ _) = True +isSigPat other = False patsAreAllLits :: [Pat id] -> Bool patsAreAllLits pat_list = all isLitPat pat_list @@ -283,80 +285,3 @@ isLitPat (NPlusKPatOut _ _ _ _) = True isLitPat other = False \end{code} -%************************************************************************ -%* * -%* Gathering stuff out of patterns -%* * -%************************************************************************ - -This function @collectPatBinders@ works with the ``collectBinders'' -functions for @HsBinds@, etc. The order in which the binders are -collected is important; see @HsBinds.lhs@. - -It collects the bounds *value* variables in renamed patterns; type variables -are *not* collected. - -\begin{code} -collectPatBinders :: LPat a -> [a] -collectPatBinders pat = map unLoc (collectLocatedPatBinders pat) - -collectLocatedPatBinders :: LPat a -> [Located a] -collectLocatedPatBinders pat = collectl pat [] - -collectPatsBinders :: [LPat a] -> [a] -collectPatsBinders pats = map unLoc (collectLocatedPatsBinders pats) - -collectLocatedPatsBinders :: [LPat a] -> [Located a] -collectLocatedPatsBinders pats = foldr collectl [] pats - -collectl (L l (VarPat var)) bndrs = L l var : bndrs -collectl pat bndrs = collect (unLoc pat) bndrs - -collect (WildPat _) bndrs = bndrs -collect (LazyPat pat) bndrs = collectl pat bndrs -collect (AsPat a pat) bndrs = a : collectl pat bndrs -collect (ParPat pat) bndrs = collectl pat bndrs - -collect (ListPat pats _) bndrs = foldr collectl bndrs pats -collect (PArrPat pats _) bndrs = foldr collectl bndrs pats -collect (TuplePat pats _) bndrs = foldr collectl bndrs pats - -collect (ConPatIn c ps) bndrs = foldr collectl bndrs (hsConArgs ps) -collect (ConPatOut c ps _ _ ds) bndrs = map noLoc ds - ++ foldr collectl bndrs (hsConArgs ps) - -collect (LitPat _) bndrs = bndrs -collect (NPatIn _ _) bndrs = bndrs -collect (NPatOut _ _ _) bndrs = bndrs - -collect (NPlusKPatIn n _ _) bndrs = n : bndrs -collect (NPlusKPatOut n _ _ _) bndrs = n : bndrs - -collect (SigPatIn pat _) bndrs = collectl pat bndrs -collect (SigPatOut pat _ _) bndrs = collectl pat bndrs -collect (TypePat ty) bndrs = bndrs -collect (DictPat ids1 ids2) bndrs = map noLoc ids1 ++ map noLoc ids2 - ++ bndrs -\end{code} - -\begin{code} -collectSigTysFromPats :: [InPat name] -> [LHsType name] -collectSigTysFromPats pats = foldr collect_lpat [] pats - -collectSigTysFromPat :: InPat name -> [LHsType name] -collectSigTysFromPat pat = collect_lpat pat [] - -collect_lpat pat acc = collect_pat (unLoc pat) acc - -collect_pat (SigPatIn pat ty) acc = collect_lpat pat (ty:acc) -collect_pat (TypePat ty) acc = ty:acc - -collect_pat (LazyPat pat) acc = collect_lpat pat acc -collect_pat (AsPat a pat) acc = collect_lpat pat acc -collect_pat (ParPat pat) acc = collect_lpat pat acc -collect_pat (ListPat pats _) acc = foldr collect_lpat acc pats -collect_pat (PArrPat pats _) acc = foldr collect_lpat acc pats -collect_pat (TuplePat pats _) acc = foldr collect_lpat acc pats -collect_pat (ConPatIn c ps) acc = foldr collect_lpat acc (hsConArgs ps) -collect_pat other acc = acc -- Literals, vars, wildcard -\end{code} diff --git a/ghc/compiler/hsSyn/HsTypes.lhs b/ghc/compiler/hsSyn/HsTypes.lhs index fdcc3e29d6..03d414a0e5 100644 --- a/ghc/compiler/hsSyn/HsTypes.lhs +++ b/ghc/compiler/hsSyn/HsTypes.lhs @@ -10,6 +10,9 @@ module HsTypes ( HsExplicitForAll(..), HsContext, LHsContext, HsPred(..), LHsPred, + + LBangType, BangType, HsBang(..), + getBangType, getBangStrictness, mkExplicitHsForAllTy, mkImplicitHsForAllTy, hsTyVarName, hsTyVarNames, replaceTyVarName, @@ -71,6 +74,35 @@ placeHolderName = mkInternalName unboundKey noSrcLoc \end{code} +%************************************************************************ +%* * +\subsection{Bang annotations} +%* * +%************************************************************************ + +\begin{code} +type LBangType name = Located (BangType name) +type BangType name = HsType name -- Bangs are in the HsType data type + +data HsBang = HsNoBang -- Only used as a return value for getBangStrictness, + -- never appears on a HsBangTy + | HsStrict -- ! + | HsUnbox -- {-# UNPACK #-} ! (GHC extension, meaning "unbox") + +instance Outputable HsBang where + ppr (HsNoBang) = empty + ppr (HsStrict) = char '!' + ppr (HsUnbox) = ptext SLIT("!!") + +getBangType :: LHsType a -> LHsType a +getBangType (L _ (HsBangTy _ ty)) = ty +getBangType ty = ty + +getBangStrictness :: LHsType a -> HsBang +getBangStrictness (L _ (HsBangTy s _)) = s +getBangStrictness _ = HsNoBang +\end{code} + %************************************************************************ %* * @@ -103,6 +135,8 @@ data HsType name | HsTyVar name -- Type variable or type constructor + | HsBangTy HsBang (LHsType name) -- Bang-style type annotations + | HsAppTy (LHsType name) (LHsType name) @@ -210,36 +244,15 @@ splitHsInstDeclTy -> ([LHsTyVarBndr name], HsContext name, name, [LHsType name]) -- Split up an instance decl type, returning the pieces --- In interface files, the instance declaration head is created --- by HsTypes.toHsType, which does not guarantee to produce a --- HsForAllTy. For example, if we had the weird decl --- instance Foo T => Foo [T] --- then we'd get the instance type --- Foo T -> Foo [T] --- So when colleting the instance context, to be on the safe side --- we gather predicate arguments --- --- For source code, the parser ensures the type will have the right shape. --- (e.g. see ParseUtil.checkInstType) - splitHsInstDeclTy inst_ty = case inst_ty of - HsForAllTy _ tvs cxt1 tau -- The type vars should have been - -- computed by now, even if they were implicit - -> (tvs, unLoc cxt1 ++ cxt2, cls, tys) - where - (cxt2, cls, tys) = split_tau (unLoc tau) - - other -> ([], cxt2, cls, tys) - where - (cxt2, cls, tys) = split_tau inst_ty - + HsParTy (L _ ty) -> splitHsInstDeclTy ty + HsForAllTy _ tvs cxt (L _ ty) -> split_tau tvs (unLoc cxt) ty + other -> split_tau [] [] other + -- The type vars should have been computed by now, even if they were implicit where - split_tau (HsFunTy (L loc (HsPredTy p)) ty) = (L loc p : ps, cls, tys) - where - (ps, cls, tys) = split_tau (unLoc ty) - split_tau (HsPredTy (HsClassP cls tys)) = ([], cls, tys) - split_tau other = pprPanic "splitHsInstDeclTy" (ppr inst_ty) + split_tau tvs cxt (HsPredTy (HsClassP cls tys)) = (tvs, cxt, cls, tys) + split_tau tvs cxt (HsParTy (L _ ty)) = split_tau tvs cxt ty \end{code} @@ -320,6 +333,8 @@ ppr_mono_ty ctxt_prec (HsForAllTy exp tvs ctxt ty) = maybeParen ctxt_prec pREC_FUN $ sep [pprHsForAll exp tvs ctxt, ppr_mono_lty pREC_TOP ty] +-- gaw 2004 +ppr_mono_ty ctxt_prec (HsBangTy b ty) = ppr b <> ppr ty ppr_mono_ty ctxt_prec (HsTyVar name) = ppr name ppr_mono_ty ctxt_prec (HsFunTy ty1 ty2) = ppr_fun_ty ctxt_prec ty1 ty2 ppr_mono_ty ctxt_prec (HsTupleTy con tys) = tupleParens con (interpp'SP tys) diff --git a/ghc/compiler/hsSyn/HsUtils.lhs b/ghc/compiler/hsSyn/HsUtils.lhs index b864e16248..582e0f01e3 100644 --- a/ghc/compiler/hsSyn/HsUtils.lhs +++ b/ghc/compiler/hsSyn/HsUtils.lhs @@ -52,10 +52,11 @@ just attach noSrcSpan to everything. mkHsPar :: LHsExpr id -> LHsExpr id mkHsPar e = L (getLoc e) (HsPar e) -mkSimpleMatch :: [LPat id] -> LHsExpr id -> Type -> LMatch id -mkSimpleMatch pats rhs rhs_ty +-- gaw 2004 +mkSimpleMatch :: [LPat id] -> LHsExpr id -> LMatch id +mkSimpleMatch pats rhs = L loc $ - Match pats Nothing (GRHSs (unguardedRHS rhs) [] rhs_ty) + Match pats Nothing (GRHSs (unguardedRHS rhs) []) where loc = case pats of [] -> getLoc rhs @@ -74,13 +75,17 @@ mkHsTyApp :: LHsExpr name -> [Type] -> LHsExpr name mkHsTyApp expr [] = expr mkHsTyApp expr tys = L (getLoc expr) (TyApp expr tys) +mkHsDictApp :: LHsExpr name -> [name] -> LHsExpr name mkHsDictApp expr [] = expr mkHsDictApp expr dict_vars = L (getLoc expr) (DictApp expr dict_vars) mkHsLam :: [LPat id] -> LHsExpr id -> LHsExpr id -mkHsLam pats body = mkHsPar (L (getLoc match) (HsLam match)) +mkHsLam pats body = mkHsPar (L (getLoc body) (HsLam matches)) where - match = mkSimpleMatch pats body placeHolderType + matches = mkMatchGroup [mkSimpleMatch pats body] + +mkMatchGroup :: [LMatch id] -> MatchGroup id +mkMatchGroup matches = MatchGroup matches placeHolderType mkHsTyLam [] expr = expr mkHsTyLam tyvars expr = L (getLoc expr) (TyLam tyvars expr) @@ -88,10 +93,10 @@ mkHsTyLam tyvars expr = L (getLoc expr) (TyLam tyvars expr) mkHsDictLam [] expr = expr mkHsDictLam dicts expr = L (getLoc expr) (DictLam dicts expr) -mkHsLet :: Bag (LHsBind name) -> LHsExpr name -> LHsExpr name +mkHsLet :: LHsBinds name -> LHsExpr name -> LHsExpr name mkHsLet binds expr - | isEmptyBag binds = expr - | otherwise = L (getLoc expr) (HsLet [HsBindGroup binds [] Recursive] expr) + | isEmptyLHsBinds binds = expr + | otherwise = L (getLoc expr) (HsLet [HsBindGroup binds [] Recursive] expr) mkHsConApp :: DataCon -> [Type] -> [HsExpr Id] -> LHsExpr Id -- Used for constructing dictinoary terms etc, so no locations @@ -103,11 +108,12 @@ mkHsConApp data_con tys args mkSimpleHsAlt :: LPat id -> LHsExpr id -> LMatch id -- A simple lambda with a single pattern, no binds, no guards; pre-typechecking mkSimpleHsAlt pat expr - = mkSimpleMatch [pat] expr placeHolderType + = mkSimpleMatch [pat] expr glueBindsOnGRHSs :: HsBindGroup id -> GRHSs id -> GRHSs id -glueBindsOnGRHSs binds1 (GRHSs grhss binds2 ty) - = GRHSs grhss (binds1 : binds2) ty +-- gaw 2004 +glueBindsOnGRHSs binds1 (GRHSs grhss binds2) + = GRHSs grhss (binds1 : binds2) -- These are the bits of syntax that contain rebindable names -- See RnEnv.lookupSyntaxName @@ -187,10 +193,10 @@ nlHsDo ctxt stmts = noLoc (mkHsDo ctxt stmts) nlHsOpApp e1 op e2 = noLoc (mkHsOpApp e1 op e2) -nlHsLam match = noLoc (HsLam match) +nlHsLam match = noLoc (HsLam (mkMatchGroup [match])) nlHsPar e = noLoc (HsPar e) nlHsIf cond true false = noLoc (HsIf cond true false) -nlHsCase expr matches = noLoc (HsCase expr matches) +nlHsCase expr matches = noLoc (HsCase expr (mkMatchGroup matches)) nlTuple exprs box = noLoc (ExplicitTuple exprs box) nlList exprs = noLoc (ExplicitList placeHolderType exprs) @@ -215,7 +221,7 @@ nlParStmt stuff = noLoc (ParStmt stuff) \begin{code} mkVarBind :: SrcSpan -> RdrName -> LHsExpr RdrName -> LHsBind RdrName -mkVarBind loc var rhs = mk_easy_FunBind loc var [] emptyBag rhs +mkVarBind loc var rhs = mk_easy_FunBind loc var [] emptyLHsBinds rhs mk_easy_FunBind :: SrcSpan -> RdrName -> [LPat RdrName] -> LHsBinds RdrName -> LHsExpr RdrName @@ -223,7 +229,7 @@ mk_easy_FunBind :: SrcSpan -> RdrName -> [LPat RdrName] mk_easy_FunBind loc fun pats binds expr = L loc (FunBind (L loc fun) False{-not infix-} - [mk_easy_Match pats binds expr]) + (mkMatchGroup [mk_easy_Match pats binds expr])) mk_easy_Match pats binds expr = mkMatch pats expr [HsBindGroup binds [] Recursive] @@ -239,12 +245,13 @@ mk_FunBind :: SrcSpan mk_FunBind loc fun [] = panic "TcGenDeriv:mk_FunBind" mk_FunBind loc fun pats_and_exprs = L loc (FunBind (L loc fun) False{-not infix-} - [mkMatch p e [] | (p,e) <-pats_and_exprs]) + (mkMatchGroup [mkMatch p e [] | (p,e) <-pats_and_exprs])) mkMatch :: [LPat id] -> LHsExpr id -> [HsBindGroup id] -> LMatch id mkMatch pats expr binds = noLoc (Match (map paren pats) Nothing - (GRHSs (unguardedRHS expr) binds placeHolderType)) +-- gaw 2004 + (GRHSs (unguardedRHS expr) binds)) where paren p = case p of L _ (VarPat _) -> p @@ -278,8 +285,8 @@ collectGroupBinders groups = foldr collect_group [] groups collectAcc :: HsBind name -> [Located name] -> [Located name] -collectAcc (PatBind pat _) acc = collectLocatedPatBinders pat ++ acc -collectAcc (FunBind f _ _) acc = f : acc +collectAcc (PatBind pat _ _) acc = collectLocatedPatBinders pat ++ acc +collectAcc (FunBind f _ _) acc = f : acc collectAcc (VarBind f _) acc = noLoc f : acc collectAcc (AbsBinds _ _ dbinds _ binds) acc = [noLoc dp | (_,dp,_) <- dbinds] ++ acc @@ -312,15 +319,13 @@ collectSigTysFromHsBind :: LHsBind name -> [LHsType name] collectSigTysFromHsBind bind = go (unLoc bind) where - go (PatBind pat _) = collectSigTysFromPat pat - go (FunBind f _ ms) = go_matches (map unLoc ms) - + go (PatBind pat _ _) + = collectSigTysFromPat pat + go (FunBind f _ (MatchGroup ms _)) + = [sig | L _ (Match [] (Just sig) _) <- ms] -- A binding like x :: a = f y -- is parsed as FunMonoBind, but for this purpose we -- want to treat it as a pattern binding - go_matches [] = [] - go_matches (Match [] (Just sig) _ : matches) = sig : go_matches matches - go_matches (match : matches) = go_matches matches \end{code} %************************************************************************ @@ -344,3 +349,86 @@ collectStmtBinders (ResultStmt _) = [] collectStmtBinders (RecStmt ss _ _ _) = collectStmtsBinders ss collectStmtBinders other = panic "collectStmtBinders" \end{code} + + +%************************************************************************ +%* * +%* Gathering stuff out of patterns +%* * +%************************************************************************ + +This function @collectPatBinders@ works with the ``collectBinders'' +functions for @HsBinds@, etc. The order in which the binders are +collected is important; see @HsBinds.lhs@. + +It collects the bounds *value* variables in renamed patterns; type variables +are *not* collected. + +\begin{code} +collectPatBinders :: LPat a -> [a] +collectPatBinders pat = map unLoc (collectLocatedPatBinders pat) + +collectLocatedPatBinders :: LPat a -> [Located a] +collectLocatedPatBinders pat = collectl pat [] + +collectPatsBinders :: [LPat a] -> [a] +collectPatsBinders pats = map unLoc (collectLocatedPatsBinders pats) + +collectLocatedPatsBinders :: [LPat a] -> [Located a] +collectLocatedPatsBinders pats = foldr collectl [] pats + +--------------------- +collectl (L l (VarPat var)) bndrs = L l var : bndrs +collectl (L l (VarPatOut var bs)) bndrs = L l var : collectHsBindLocatedBinders bs + ++ bndrs +collectl (L l pat) bndrs = collect pat bndrs + +--------------------- +collect (WildPat _) bndrs = bndrs +collect (LazyPat pat) bndrs = collectl pat bndrs +collect (AsPat a pat) bndrs = a : collectl pat bndrs +collect (ParPat pat) bndrs = collectl pat bndrs + +collect (ListPat pats _) bndrs = foldr collectl bndrs pats +collect (PArrPat pats _) bndrs = foldr collectl bndrs pats +collect (TuplePat pats _) bndrs = foldr collectl bndrs pats + +collect (ConPatIn c ps) bndrs = foldr collectl bndrs (hsConArgs ps) +collect (ConPatOut c _ ds bs ps _) bndrs = map noLoc ds + ++ collectHsBindLocatedBinders bs + ++ foldr collectl bndrs (hsConArgs ps) +collect (LitPat _) bndrs = bndrs +collect (NPatIn _ _) bndrs = bndrs +collect (NPatOut _ _ _) bndrs = bndrs + +collect (NPlusKPatIn n _ _) bndrs = n : bndrs +collect (NPlusKPatOut n _ _ _) bndrs = n : bndrs + +collect (SigPatIn pat _) bndrs = collectl pat bndrs +collect (SigPatOut pat _) bndrs = collectl pat bndrs +collect (TypePat ty) bndrs = bndrs +collect (DictPat ids1 ids2) bndrs = map noLoc ids1 ++ map noLoc ids2 + ++ bndrs +\end{code} + +\begin{code} +collectSigTysFromPats :: [InPat name] -> [LHsType name] +collectSigTysFromPats pats = foldr collect_lpat [] pats + +collectSigTysFromPat :: InPat name -> [LHsType name] +collectSigTysFromPat pat = collect_lpat pat [] + +collect_lpat pat acc = collect_pat (unLoc pat) acc + +collect_pat (SigPatIn pat ty) acc = collect_lpat pat (ty:acc) +collect_pat (TypePat ty) acc = ty:acc + +collect_pat (LazyPat pat) acc = collect_lpat pat acc +collect_pat (AsPat a pat) acc = collect_lpat pat acc +collect_pat (ParPat pat) acc = collect_lpat pat acc +collect_pat (ListPat pats _) acc = foldr collect_lpat acc pats +collect_pat (PArrPat pats _) acc = foldr collect_lpat acc pats +collect_pat (TuplePat pats _) acc = foldr collect_lpat acc pats +collect_pat (ConPatIn c ps) acc = foldr collect_lpat acc (hsConArgs ps) +collect_pat other acc = acc -- Literals, vars, wildcard +\end{code} diff --git a/ghc/compiler/iface/BinIface.hs b/ghc/compiler/iface/BinIface.hs index a0e932ed88..286c612dfb 100644 --- a/ghc/compiler/iface/BinIface.hs +++ b/ghc/compiler/iface/BinIface.hs @@ -693,10 +693,13 @@ instance Binary IfaceExpr where putByte bh 4 put_ bh ag put_ bh ah - put_ bh (IfaceCase ai aj ak) = do +-- gaw 2004 + put_ bh (IfaceCase ai aj al ak) = do putByte bh 5 put_ bh ai put_ bh aj +-- gaw 2004 + put_ bh al put_ bh ak put_ bh (IfaceLet al am) = do putByte bh 6 @@ -734,8 +737,11 @@ instance Binary IfaceExpr where return (IfaceApp ag ah) 5 -> do ai <- get bh aj <- get bh +-- gaw 2004 + al <- get bh ak <- get bh - return (IfaceCase ai aj ak) +-- gaw 2004 + return (IfaceCase ai aj al ak) 6 -> do al <- get bh am <- get bh return (IfaceLet al am) @@ -874,7 +880,7 @@ instance Binary IfaceDecl where put_ bh idinfo put_ bh (IfaceForeign ae af) = error "Binary.put_(IfaceDecl): IfaceForeign" - put_ bh (IfaceData a1 a2 a3 a4 a5 a6 a7) = do + put_ bh (IfaceData a1 a2 a3 a4 a5 a6) = do putByte bh 2 put_ bh a1 put_ bh a2 @@ -882,7 +888,6 @@ instance Binary IfaceDecl where put_ bh a4 put_ bh a5 put_ bh a6 - put_ bh a7 put_ bh (IfaceSyn aq ar as at) = do putByte bh 3 @@ -914,8 +919,7 @@ instance Binary IfaceDecl where a4 <- get bh a5 <- get bh a6 <- get bh - a7 <- get bh - return (IfaceData a1 a2 a3 a4 a5 a6 a7) + return (IfaceData a1 a2 a3 a4 a5 a6) 3 -> do aq <- get bh ar <- get bh @@ -942,37 +946,53 @@ instance Binary IfaceInst where instance Binary IfaceConDecls where put_ bh IfAbstractTyCon = putByte bh 0 - put_ bh (IfDataTyCon cs) = do { putByte bh 1 - ; put_ bh cs } + put_ bh (IfDataTyCon st cs) = do { putByte bh 1 + ; put_ bh st + ; put_ bh cs } put_ bh (IfNewTyCon c) = do { putByte bh 2 ; put_ bh c } get bh = do h <- getByte bh case h of 0 -> return IfAbstractTyCon - 1 -> do aa <- get bh - return (IfDataTyCon aa) + 1 -> do st <- get bh + cs <- get bh + return (IfDataTyCon st cs) _ -> do aa <- get bh return (IfNewTyCon aa) instance Binary IfaceConDecl where - put_ bh (IfaceConDecl a1 a2 a3 a4 a5 a6 a7) = do + put_ bh (IfVanillaCon a1 a2 a3 a4 a5) = do + putByte bh 0 + put_ bh a1 + put_ bh a2 + put_ bh a3 + put_ bh a4 + put_ bh a5 + put_ bh (IfGadtCon a1 a2 a3 a4 a5 a6) = do + putByte bh 1 put_ bh a1 put_ bh a2 put_ bh a3 put_ bh a4 put_ bh a5 put_ bh a6 - put_ bh a7 get bh = do - a1 <- get bh - a2 <- get bh - a3 <- get bh - a4 <- get bh - a5 <- get bh - a6 <- get bh - a7 <- get bh - return (IfaceConDecl a1 a2 a3 a4 a5 a6 a7) + h <- getByte bh + case h of + 0 -> do a1 <- get bh + a2 <- get bh + a3 <- get bh + a4 <- get bh + a5 <- get bh + return (IfVanillaCon a1 a2 a3 a4 a5) + _ -> do a1 <- get bh + a2 <- get bh + a3 <- get bh + a4 <- get bh + a5 <- get bh + a6 <- get bh + return (IfGadtCon a1 a2 a3 a4 a5 a6) instance Binary IfaceClassOp where put_ bh (IfaceClassOp n def ty) = do diff --git a/ghc/compiler/iface/BuildTyCl.lhs b/ghc/compiler/iface/BuildTyCl.lhs index 862af64665..8624ff9349 100644 --- a/ghc/compiler/iface/BuildTyCl.lhs +++ b/ghc/compiler/iface/BuildTyCl.lhs @@ -14,12 +14,11 @@ module BuildTyCl ( import IfaceEnv ( newImplicitBinder ) import TcRnMonad -import Subst ( substTyWith ) import Util ( zipLazy ) -import FieldLabel ( allFieldLabelTags, mkFieldLabel, fieldLabelName ) -import VarSet -import DataCon ( DataCon, dataConTyCon, dataConOrigArgTys, mkDataCon, dataConFieldLabels ) +import DataCon ( DataCon, isNullarySrcDataCon, + mkDataCon, dataConFieldLabels, dataConOrigArgTys ) import Var ( tyVarKind, TyVar, Id ) +import VarSet ( isEmptyVarSet, intersectVarSet ) import TysWiredIn ( unitTy ) import BasicTypes ( RecFlag, StrictnessMark(..) ) import Name ( Name ) @@ -27,11 +26,12 @@ import OccName ( mkDataConWrapperOcc, mkDataConWorkerOcc, mkClassTyConOcc, mkClassDataConOcc, mkSuperDictSelOcc ) import MkId ( mkDataConIds, mkRecordSelId, mkDictSelId ) import Class ( mkClass, Class( classTyCon), FunDep, DefMeth(..) ) -import TyCon ( mkSynTyCon, mkAlgTyCon, visibleDataCons, +import TyCon ( FieldLabel, mkSynTyCon, mkAlgTyCon, visibleDataCons, tyConStupidTheta, tyConDataCons, isNewTyCon, mkClassTyCon, TyCon( tyConTyVars ), ArgVrcs, AlgTyConRhs(..), newTyConRhs, visibleDataCons ) -import Type ( mkArrowKinds, liftedTypeKind, tyVarsOfTypes, typeKind, - tyVarsOfPred, splitTyConApp_maybe, mkPredTys, ThetaType, Type ) +import Type ( mkArrowKinds, liftedTypeKind, typeKind, tyVarsOfTypes, tyVarsOfPred, + splitTyConApp_maybe, mkPredTys, mkTyVarTys, ThetaType, Type, + substTyWith, zipTopTvSubst, substTheta ) import Outputable import List ( nubBy ) @@ -47,17 +47,17 @@ buildSynTyCon name tvs rhs_ty arg_vrcs ------------------------------------------------------ -buildAlgTyCon :: Name -> [TyVar] -> ThetaType +buildAlgTyCon :: Name -> [TyVar] -> AlgTyConRhs -> ArgVrcs -> RecFlag -> Bool -- True <=> want generics functions -> TcRnIf m n TyCon -buildAlgTyCon tc_name tvs ctxt rhs arg_vrcs is_rec want_generics - = do { let { tycon = mkAlgTyCon tc_name kind tvs ctxt arg_vrcs - rhs sel_ids is_rec want_generics +buildAlgTyCon tc_name tvs rhs arg_vrcs is_rec want_generics + = do { let { tycon = mkAlgTyCon tc_name kind tvs arg_vrcs + rhs fields is_rec want_generics ; kind = mkArrowKinds (map tyVarKind tvs) liftedTypeKind - ; sel_ids = mkRecordSelectors tycon rhs + ; fields = mkTyConFields tycon rhs } ; return tycon } @@ -65,37 +65,63 @@ buildAlgTyCon tc_name tvs ctxt rhs arg_vrcs is_rec want_generics mkAbstractTyConRhs :: AlgTyConRhs mkAbstractTyConRhs = AbstractTyCon -mkDataTyConRhs :: [DataCon] -> AlgTyConRhs -mkDataTyConRhs cons - = DataTyCon cons (all is_nullary cons) +mkDataTyConRhs :: Maybe ThetaType -> [DataCon] -> AlgTyConRhs +mkDataTyConRhs mb_theta cons + = DataTyCon mb_theta cons (all isNullarySrcDataCon cons) + +mkNewTyConRhs :: TyCon -> DataCon -> AlgTyConRhs +mkNewTyConRhs tycon con + = NewTyCon con rhs_ty (mkNewTyConRep tycon) where - is_nullary con = null (dataConOrigArgTys con) - -- NB (null . dataConOrigArgTys). It used to say isNullaryDataCon - -- but that looks at the *representation* arity, and isEnumerationType - -- refers to the *source* code definition - -mkNewTyConRhs :: DataCon -> AlgTyConRhs -mkNewTyConRhs con - = NewTyCon con -- The constructor - (head (dataConOrigArgTys con)) -- The RHS type - (mkNewTyConRep (dataConTyCon con)) -- The ultimate rep type + rhs_ty = head (dataConOrigArgTys con) + -- Newtypes are guaranteed vanilla, so OrigArgTys will do +mkNewTyConRep :: TyCon -- The original type constructor + -> Type -- Chosen representation type + -- (guaranteed not to be another newtype) + +-- Find the representation type for this newtype TyCon +-- Remember that the representation type is the *ultimate* representation +-- type, looking through other newtypes. +-- +-- The non-recursive newtypes are easy, because they look transparent +-- to splitTyConApp_maybe, but recursive ones really are represented as +-- TyConApps (see TypeRep). +-- +-- The trick is to to deal correctly with recursive newtypes +-- such as newtype T = MkT T + +mkNewTyConRep tc + | null (tyConDataCons tc) = unitTy + -- External Core programs can have newtypes with no data constructors + | otherwise = go [] tc + where + -- Invariant: tc is a NewTyCon + -- tcs have been seen before + go tcs tc + | tc `elem` tcs = unitTy + | otherwise + = case splitTyConApp_maybe rhs_ty of + Just (tc', tys) | isNewTyCon tc' + -> substTyWith tc_tvs tys (go (tc:tcs) tc') + other -> rhs_ty + where + (tc_tvs, rhs_ty) = newTyConRhs tc + ------------------------------------------------------ -buildDataCon :: Name -> Bool +buildDataCon :: Name -> Bool -> Bool -> [StrictnessMark] -> [Name] -- Field labels -> [TyVar] -> ThetaType - -> [TyVar] -> ThetaType - -> [Type] -> TyCon + -> [Type] -> TyCon -> [Type] -> TcRnIf m n DataCon -- A wrapper for DataCon.mkDataCon that -- a) makes the worker Id -- b) makes the wrapper Id if necessary, including -- allocating its unique (hence monadic) -buildDataCon src_name declared_infix arg_stricts field_lbl_names - tyvars ctxt ex_tyvars ex_ctxt - arg_tys tycon +buildDataCon src_name declared_infix vanilla arg_stricts field_lbls + tyvars ctxt arg_tys tycon res_tys = do { wrap_name <- newImplicitBinder src_name mkDataConWrapperOcc ; work_name <- newImplicitBinder src_name mkDataConWorkerOcc -- This last one takes the name of the data constructor in the source @@ -103,43 +129,44 @@ buildDataCon src_name declared_infix arg_stricts field_lbl_names -- space, and makes it into a "real data constructor name" ; let - -- Make the FieldLabels - -- The zipLazy avoids forcing the arg_tys too early - final_lbls = [ mkFieldLabel name tycon ty tag - | ((name, tag), ty) <- (field_lbl_names `zip` allFieldLabelTags) - `zipLazy` arg_tys - ] - - ctxt' = thinContext arg_tys ctxt - data_con = mkDataCon src_name declared_infix - arg_stricts final_lbls - tyvars ctxt' - ex_tyvars ex_ctxt - arg_tys tycon dc_ids + stupid_ctxt = mkDataConStupidTheta tycon arg_tys res_tys + data_con = mkDataCon src_name declared_infix vanilla + arg_stricts field_lbls + tyvars stupid_ctxt ctxt + arg_tys tycon res_tys dc_ids dc_ids = mkDataConIds wrap_name work_name data_con ; returnM data_con } --- The context for a data constructor should be limited to + +-- The stupid context for a data constructor should be limited to -- the type variables mentioned in the arg_tys -thinContext arg_tys ctxt - = filter in_arg_tys ctxt +mkDataConStupidTheta tycon arg_tys res_tys + | null stupid_theta = [] -- The common case + | otherwise = filter in_arg_tys stupid_theta where - arg_tyvars = tyVarsOfTypes arg_tys - in_arg_tys pred = not $ isEmptyVarSet $ + tc_subst = zipTopTvSubst (tyConTyVars tycon) res_tys + stupid_theta = substTheta tc_subst (tyConStupidTheta tycon) + arg_tyvars = tyVarsOfTypes arg_tys + in_arg_tys pred = not $ isEmptyVarSet $ tyVarsOfPred pred `intersectVarSet` arg_tyvars ------------------------------------------------------ -mkRecordSelectors :: TyCon -> AlgTyConRhs -> [Id] -mkRecordSelectors tycon data_cons +mkTyConFields :: TyCon -> AlgTyConRhs -> [(FieldLabel,Type,Id)] +mkTyConFields tycon rhs = -- We'll check later that fields with the same name -- from different constructors have the same type. - [ mkRecordSelId tycon field - | field <- nubBy eq_name fields ] + [ (fld, ty, mkRecordSelId tycon fld ty) + | (fld, ty) <- nubBy eq_fld all_fld_tys ] where - fields = [ field | con <- visibleDataCons data_cons, - field <- dataConFieldLabels con ] - eq_name field1 field2 = fieldLabelName field1 == fieldLabelName field2 + all_fld_tys = concatMap fld_tys_of (visibleDataCons rhs) + fld_tys_of con = dataConFieldLabels con `zipLazy` + dataConOrigArgTys con + -- The laziness means that the type isn't sucked in prematurely + -- Only vanilla datacons have fields at all, and they + -- share the tycon's type variables => datConOrigArgTys will do + + eq_fld (f1,_) (f2,_) = f1 == f2 \end{code} @@ -177,13 +204,13 @@ buildClass class_name tvs sc_theta fds sig_stuff tc_isrec tc_vrcs | (op_name, dm_info, _) <- sig_stuff ] } -- Build the selector id and default method id - ; dict_con <- buildDataCon datacon_name False {- Not declared infix -} + ; dict_con <- buildDataCon datacon_name + False -- Not declared infix + True -- Is vanilla; tyvars same as tycon (map (const NotMarkedStrict) dict_component_tys) [{- No labelled fields -}] - tvs [{-No context-}] - [{-No existential tyvars-}] [{-Or context-}] - dict_component_tys - (classTyCon clas) + tvs [{-No context-}] dict_component_tys + (classTyCon clas) (mkTyVarTys tvs) ; let { clas = mkClass class_name tvs fds sc_theta sc_sel_ids op_items @@ -202,47 +229,11 @@ buildClass class_name tvs sc_theta fds sig_stuff tc_isrec tc_vrcs ; clas_kind = mkArrowKinds (map tyVarKind tvs) liftedTypeKind ; rhs = case dict_component_tys of - [rep_ty] -> mkNewTyConRhs dict_con - other -> mkDataTyConRhs [dict_con] + [rep_ty] -> mkNewTyConRhs tycon dict_con + other -> mkDataTyConRhs Nothing [dict_con] } ; return clas })} \end{code} ------------------------------------------------------- -\begin{code} -mkNewTyConRep :: TyCon -- The original type constructor - -> Type -- Chosen representation type - -- (guaranteed not to be another newtype) - --- Find the representation type for this newtype TyCon --- Remember that the representation type is the *ultimate* representation --- type, looking through other newtypes. --- --- The non-recursive newtypes are easy, because they look transparent --- to splitTyConApp_maybe, but recursive ones really are represented as --- TyConApps (see TypeRep). --- --- The trick is to to deal correctly with recursive newtypes --- such as newtype T = MkT T - -mkNewTyConRep tc - | null (tyConDataCons tc) = unitTy - -- External Core programs can have newtypes with no data constructors - | otherwise = go [] tc - where - -- Invariant: tc is a NewTyCon - -- tcs have been seen before - go tcs tc - | tc `elem` tcs = unitTy - | otherwise - = case splitTyConApp_maybe rep_ty of - Nothing -> rep_ty - Just (tc', tys) | not (isNewTyCon tc') -> rep_ty - | otherwise -> go1 (tc:tcs) tc' tys - where - (_,rep_ty) = newTyConRhs tc - - go1 tcs tc tys = substTyWith (tyConTyVars tc) tys (go tcs tc) -\end{code} diff --git a/ghc/compiler/iface/IfaceEnv.lhs b/ghc/compiler/iface/IfaceEnv.lhs index 9e88ee9301..6922ac9a96 100644 --- a/ghc/compiler/iface/IfaceEnv.lhs +++ b/ghc/compiler/iface/IfaceEnv.lhs @@ -18,10 +18,8 @@ module IfaceEnv ( import TcRnMonad import IfaceType ( IfaceExtName(..), IfaceTyCon(..), ifaceTyConName ) import TysWiredIn ( tupleTyCon, tupleCon ) -import HscTypes ( NameCache(..), HscEnv(..), - TyThing, ExternalPackageState(..), OrigNameCache ) +import HscTypes ( NameCache(..), HscEnv(..), OrigNameCache ) import TyCon ( TyCon, tyConName ) -import Class ( Class ) import DataCon ( dataConWorkId, dataConName ) import Var ( TyVar, Id, varName ) import Name ( Name, nameUnique, nameModule, @@ -29,11 +27,9 @@ import Name ( Name, nameUnique, nameModule, getOccName, nameParent_maybe, isWiredInName, mkIPName, mkExternalName, mkInternalName ) -import NameEnv import OccName ( OccName, isTupleOcc_maybe, tcName, dataName, lookupOccEnv, unitOccEnv, extendOccEnv, extendOccEnvList ) import PrelNames ( gHC_PRIM_Name, pREL_TUP_Name ) -import HscTypes ( ExternalPackageState, NameCache, TyThing(..) ) import Module ( Module, ModuleName, moduleName, mkPackageModule, emptyModuleEnv, lookupModuleEnvByName, extendModuleEnv_C ) import UniqSupply ( UniqSupply, splitUniqSupply, uniqFromSupply, uniqsFromSupply ) diff --git a/ghc/compiler/iface/IfaceSyn.lhs b/ghc/compiler/iface/IfaceSyn.lhs index 9163560a4c..6a0a1c79ba 100644 --- a/ghc/compiler/iface/IfaceSyn.lhs +++ b/ghc/compiler/iface/IfaceSyn.lhs @@ -40,9 +40,9 @@ import IfaceType import FunDeps ( pprFundeps ) import NewDemand ( StrictSig, pprIfaceStrictSig ) -import TcType ( deNoteType, mkSigmaTy, tcSplitDFunTy, mkClassPred ) -import Type ( TyThing(..), mkForAllTys, mkFunTys, splitForAllTys, funResultTy, - mkTyVarTys, mkTyConApp, mkTyVarTys, mkPredTy, tidyTopType ) +import TcType ( deNoteType, tcSplitDFunTy, mkClassPred ) +import Type ( TyThing(..), mkForAllTys, splitForAllTys, funResultTy, + mkPredTy, tidyTopType ) import InstEnv ( DFunId ) import Id ( Id, idName, idType, idInfo, idArity, isDataConWorkId_maybe, isFCallId_maybe ) import NewDemand ( isTopSig ) @@ -50,12 +50,12 @@ import IdInfo ( IdInfo, CafInfo(..), WorkerInfo(..), arityInfo, cafInfo, newStrictnessInfo, workerInfo, unfoldingInfo, inlinePragInfo ) import TyCon ( TyCon, ArgVrcs, AlgTyConRhs(..), isRecursiveTyCon, isForeignTyCon, - isSynTyCon, isNewTyCon, isAlgTyCon, isPrimTyCon, isFunTyCon, + isSynTyCon, isAlgTyCon, isPrimTyCon, isFunTyCon, isTupleTyCon, tupleTyConBoxity, - tyConHasGenerics, tyConArgVrcs, tyConTheta, getSynTyConDefn, - tyConArity, tyConTyVars, algTyConRhs, tyConExtName ) + tyConHasGenerics, tyConArgVrcs, getSynTyConDefn, + tyConArity, tyConTyVars, algTcRhs, tyConExtName ) import DataCon ( dataConName, dataConSig, dataConFieldLabels, dataConStrictMarks, - dataConTyCon, dataConIsInfix ) + dataConTyCon, dataConIsInfix, isVanillaDataCon ) import Class ( FunDep, DefMeth, classExtraBigSig, classTyCon ) import OccName ( OccName, OccEnv, lookupOccEnv, emptyOccEnv, lookupOccEnv, extendOccEnv, emptyOccEnv, @@ -92,8 +92,7 @@ data IfaceDecl ifType :: IfaceType, ifIdInfo :: IfaceIdInfo } - | IfaceData { ifCtxt :: IfaceContext, -- Context - ifName :: OccName, -- Type constructor + | IfaceData { ifName :: OccName, -- Type constructor ifTyVars :: [IfaceTvBndr], -- Type variables ifCons :: IfaceConDecls, -- Includes new/data info ifRec :: RecFlag, -- Recursive or not? @@ -109,16 +108,16 @@ data IfaceDecl ifSynRhs :: IfaceType -- synonym expansion } - | IfaceClass { ifCtxt :: IfaceContext, -- Context... - ifName :: OccName, -- Name of the class - ifTyVars :: [IfaceTvBndr], -- Type variables - ifFDs :: [FunDep OccName], -- Functional dependencies - ifSigs :: [IfaceClassOp], -- Method signatures - ifRec :: RecFlag, -- Is newtype/datatype associated with the class recursive? - ifVrcs :: ArgVrcs -- ... and what are its argument variances ... + | IfaceClass { ifCtxt :: IfaceContext, -- Context... + ifName :: OccName, -- Name of the class + ifTyVars :: [IfaceTvBndr], -- Type variables + ifFDs :: [FunDep OccName], -- Functional dependencies + ifSigs :: [IfaceClassOp], -- Method signatures + ifRec :: RecFlag, -- Is newtype/datatype associated with the class recursive? + ifVrcs :: ArgVrcs -- ... and what are its argument variances ... } - | IfaceForeign { ifName :: OccName, -- Needs expanding when we move beyond .NET + | IfaceForeign { ifName :: OccName, -- Needs expanding when we move beyond .NET ifExtName :: Maybe FastString } data IfaceClassOp = IfaceClassOp OccName DefMeth IfaceType @@ -128,22 +127,30 @@ data IfaceClassOp = IfaceClassOp OccName DefMeth IfaceType data IfaceConDecls = IfAbstractTyCon -- No info - | IfDataTyCon [IfaceConDecl] -- data type decls + | IfDataTyCon -- data type decls + (Maybe IfaceContext) -- See TyCon.AlgTyConRhs; H98 or GADT + [IfaceConDecl] | IfNewTyCon IfaceConDecl -- newtype decls visibleIfConDecls :: IfaceConDecls -> [IfaceConDecl] -visibleIfConDecls IfAbstractTyCon = [] -visibleIfConDecls (IfDataTyCon cs) = cs -visibleIfConDecls (IfNewTyCon c) = [c] +visibleIfConDecls IfAbstractTyCon = [] +visibleIfConDecls (IfDataTyCon _ cs) = cs +visibleIfConDecls (IfNewTyCon c) = [c] data IfaceConDecl - = IfaceConDecl OccName -- Constructor name - Bool -- True <=> declared infix - [IfaceTvBndr] -- Existental tyvars - IfaceContext -- Existential context - [IfaceType] -- Arg types - [StrictnessMark] -- Empty (meaning all lazy), or 1-1 corresp with arg types - [OccName] -- ...ditto... (field labels) + = IfVanillaCon { + ifConOcc :: OccName, -- Constructor name + ifConInfix :: Bool, -- True <=> declared infix + ifConArgTys :: [IfaceType], -- Arg types + ifConStricts :: [StrictnessMark], -- Empty (meaning all lazy), or 1-1 corresp with arg types + ifConFields :: [OccName] } -- ...ditto... (field labels) + | IfGadtCon { + ifConOcc :: OccName, -- Constructor name + ifConTyVars :: [IfaceTvBndr], -- All tyvars + ifConCtxt :: IfaceContext, -- Non-stupid context + ifConArgTys :: [IfaceType], -- Arg types + ifConResTys :: [IfaceType], -- Result type args + ifConStricts :: [StrictnessMark] } -- Empty (meaning all lazy), or 1-1 corresp with arg types data IfaceInst = IfaceInst { ifInstHead :: IfaceType, -- Just the instance head type, quantified -- so that it'll compare alpha-wise @@ -201,7 +208,8 @@ data IfaceExpr | IfaceTuple Boxity [IfaceExpr] -- Saturated; type arguments omitted | IfaceLam IfaceBndr IfaceExpr | IfaceApp IfaceExpr IfaceExpr - | IfaceCase IfaceExpr OccName [IfaceAlt] +-- gaw 2004 + | IfaceCase IfaceExpr OccName IfaceType [IfaceAlt] | IfaceLet IfaceBinding IfaceExpr | IfaceNote IfaceNote IfaceExpr | IfaceLit Literal @@ -253,15 +261,18 @@ pprIfaceDecl (IfaceSyn {ifName = tycon, ifTyVars = tyvars, ifSynRhs = mono_ty, i 4 (vcat [equals <+> ppr mono_ty, pprVrcs vrcs]) -pprIfaceDecl (IfaceData {ifCtxt = context, ifName = tycon, ifGeneric = gen, - ifTyVars = tyvars, ifCons = condecls, ifRec = isrec, ifVrcs = vrcs}) +pprIfaceDecl (IfaceData {ifName = tycon, ifGeneric = gen, + ifTyVars = tyvars, ifCons = condecls, + ifRec = isrec, ifVrcs = vrcs}) = hang (pp_nd <+> pprIfaceDeclHead context tycon tyvars) - 4 (vcat [pprVrcs vrcs, pprRec isrec, pprGen gen, pp_condecls condecls]) + 4 (vcat [pprVrcs vrcs, pprRec isrec, pprGen gen, pp_condecls tycon condecls]) where - pp_nd = case condecls of - IfAbstractTyCon -> ptext SLIT("data") - IfDataTyCon _ -> ptext SLIT("data") - IfNewTyCon _ -> ptext SLIT("newtype") + (context, pp_nd) + = case condecls of + IfAbstractTyCon -> ([], ptext SLIT("data")) + IfDataTyCon Nothing _ -> ([], ptext SLIT("data")) + IfDataTyCon (Just c) _ -> (c, ptext SLIT("data")) + IfNewTyCon _ -> ([], ptext SLIT("newtype")) pprIfaceDecl (IfaceClass {ifCtxt = context, ifName = clas, ifTyVars = tyvars, ifFDs = fds, ifSigs = sigs, ifVrcs = vrcs, ifRec = isrec}) @@ -282,20 +293,35 @@ pprIfaceDeclHead :: IfaceContext -> OccName -> [IfaceTvBndr] -> SDoc pprIfaceDeclHead context thing tyvars = hsep [pprIfaceContext context, ppr thing, pprIfaceTvBndrs tyvars] -pp_condecls IfAbstractTyCon = ptext SLIT("{- abstract -}") -pp_condecls (IfDataTyCon cs) = equals <+> sep (punctuate (ptext SLIT(" |")) (map ppr cs)) -pp_condecls (IfNewTyCon c) = equals <+> ppr c +pp_condecls tc IfAbstractTyCon = ptext SLIT("{- abstract -}") +pp_condecls tc (IfNewTyCon c) = equals <+> pprIfaceConDecl tc c +pp_condecls tc (IfDataTyCon _ cs) = equals <+> sep (punctuate (ptext SLIT(" |")) + (map (pprIfaceConDecl tc) cs)) -instance Outputable IfaceConDecl where - ppr (IfaceConDecl name is_infix ex_tvs ex_ctxt arg_tys strs fields) - = pprIfaceForAllPart ex_tvs ex_ctxt $ - sep [ppr name <+> sep (map pprParendIfaceType arg_tys), +pprIfaceConDecl tc (IfVanillaCon { + ifConOcc = name, ifConInfix = is_infix, + ifConArgTys = arg_tys, + ifConStricts = strs, ifConFields = fields }) + = sep [ppr name <+> sep (map pprParendIfaceType arg_tys), if is_infix then ptext SLIT("Infix") else empty, if null strs then empty else nest 4 (ptext SLIT("Stricts:") <+> hsep (map ppr strs)), if null fields then empty else nest 4 (ptext SLIT("Fields:") <+> hsep (map ppr fields))] +pprIfaceConDecl tc (IfGadtCon { + ifConOcc = name, + ifConTyVars = tvs, ifConCtxt = ctxt, + ifConArgTys = arg_tys, ifConResTys = res_tys, + ifConStricts = strs }) + = sep [ppr name <+> dcolon <+> pprIfaceForAllPart tvs ctxt (ppr con_tau), + if null strs then empty + else nest 4 (ptext SLIT("Stricts:") <+> hsep (map ppr strs))] + where + con_tau = foldr1 IfaceFunTy (arg_tys ++ [tc_app]) + tc_app = IfaceTyConApp (IfaceTc (LocalTop tc)) res_tys + -- Gruesome, but jsut for debug print + instance Outputable IfaceRule where ppr (IfaceRule name act bndrs fn args rhs) = sep [hsep [doubleQuotes (ftext name), ppr act, @@ -340,13 +366,17 @@ pprIfaceExpr add_par e@(IfaceLam _ _) collect bs (IfaceLam b e) = collect (b:bs) e collect bs e = (reverse bs, e) -pprIfaceExpr add_par (IfaceCase scrut bndr [(con, bs, rhs)]) - = add_par (sep [ptext SLIT("case") <+> pprIfaceExpr noParens scrut <+> ptext SLIT("of") +-- gaw 2004 +pprIfaceExpr add_par (IfaceCase scrut bndr ty [(con, bs, rhs)]) +-- gaw 2004 + = add_par (sep [ptext SLIT("case") <+> char '@' <+> pprParendIfaceType ty <+> pprIfaceExpr noParens scrut <+> ptext SLIT("of") <+> ppr bndr <+> char '{' <+> ppr_con_bs con bs <+> arrow, pprIfaceExpr noParens rhs <+> char '}']) -pprIfaceExpr add_par (IfaceCase scrut bndr alts) - = add_par (sep [ptext SLIT("case") <+> pprIfaceExpr noParens scrut <+> ptext SLIT("of") +-- gaw 2004 +pprIfaceExpr add_par (IfaceCase scrut bndr ty alts) +-- gaw 2004 + = add_par (sep [ptext SLIT("case") <+> char '@' <+> pprParendIfaceType ty <+> pprIfaceExpr noParens scrut <+> ptext SLIT("of") <+> ppr bndr <+> char '{', nest 2 (sep (map ppr_alt alts)) <+> char '}']) @@ -458,10 +488,9 @@ tyThingToIfaceDecl _ abstract_tcs ext (ATyCon tycon) ifSynRhs = toIfaceType ext syn_ty } | isAlgTyCon tycon - = IfaceData { ifCtxt = toIfaceContext ext (tyConTheta tycon), - ifName = getOccName tycon, + = IfaceData { ifName = getOccName tycon, ifTyVars = toIfaceTvBndrs tyvars, - ifCons = ifaceConDecls (algTyConRhs tycon), + ifCons = ifaceConDecls (algTcRhs tycon), ifRec = boolToRecFlag (isRecursiveTyCon tycon), ifVrcs = tyConArgVrcs tycon, ifGeneric = tyConHasGenerics tycon } @@ -472,8 +501,7 @@ tyThingToIfaceDecl _ abstract_tcs ext (ATyCon tycon) | isPrimTyCon tycon || isFunTyCon tycon -- Needed in GHCi for ':info Int#', for example - = IfaceData { ifCtxt = [], - ifName = getOccName tycon, + = IfaceData { ifName = getOccName tycon, ifTyVars = toIfaceTvBndrs (take (tyConArity tycon) alphaTyVars), ifCons = IfAbstractTyCon, ifGeneric = False, @@ -488,7 +516,8 @@ tyThingToIfaceDecl _ abstract_tcs ext (ATyCon tycon) ifaceConDecls _ | abstract = IfAbstractTyCon ifaceConDecls (NewTyCon con _ _) = IfNewTyCon (ifaceConDecl con) - ifaceConDecls (DataTyCon cons _) = IfDataTyCon (map ifaceConDecl cons) + ifaceConDecls (DataTyCon mb_theta cons _) = IfDataTyCon (ifaceDataCtxt mb_theta) + (map ifaceConDecl cons) ifaceConDecls AbstractTyCon = IfAbstractTyCon -- The last case should never happen when we are generating an -- interface file (we're exporting this thing, so it's locally defined @@ -496,16 +525,25 @@ tyThingToIfaceDecl _ abstract_tcs ext (ATyCon tycon) -- in TcRnDriver for GHCi, when browsing a module, in which case the -- AbstractTyCon case is perfectly sensible. + ifaceDataCtxt Nothing = Nothing + ifaceDataCtxt (Just theta) = Just (toIfaceContext ext theta) + ifaceConDecl data_con - = IfaceConDecl (getOccName (dataConName data_con)) - (dataConIsInfix data_con) - (toIfaceTvBndrs ex_tyvars) - (toIfaceContext ext ex_theta) - (map (toIfaceType ext) arg_tys) - strict_marks - (map getOccName field_labels) + | isVanillaDataCon data_con + = IfVanillaCon {ifConOcc = getOccName (dataConName data_con), + ifConInfix = dataConIsInfix data_con, + ifConArgTys = map (toIfaceType ext) arg_tys, + ifConStricts = strict_marks, + ifConFields = map getOccName field_labels } + | otherwise + = IfGadtCon { ifConOcc = getOccName (dataConName data_con), + ifConTyVars = toIfaceTvBndrs tyvars, + ifConCtxt = toIfaceContext ext theta, + ifConArgTys = map (toIfaceType ext) arg_tys, + ifConResTys = map (toIfaceType ext) res_tys, + ifConStricts = strict_marks } where - (_, _, ex_tyvars, ex_theta, arg_tys, _) = dataConSig data_con + (tyvars, theta, arg_tys, _, res_tys) = dataConSig data_con field_labels = dataConFieldLabels data_con strict_marks = dataConStrictMarks data_con @@ -602,7 +640,8 @@ toIfaceExpr ext (Lit l) = IfaceLit l toIfaceExpr ext (Type ty) = IfaceType (toIfaceType ext ty) toIfaceExpr ext (Lam x b) = IfaceLam (toIfaceBndr ext x) (toIfaceExpr ext b) toIfaceExpr ext (App f a) = toIfaceApp ext f [a] -toIfaceExpr ext (Case s x as) = IfaceCase (toIfaceExpr ext s) (getOccName x) (map (toIfaceAlt ext) as) +-- gaw 2004 +toIfaceExpr ext (Case s x ty as) = IfaceCase (toIfaceExpr ext s) (getOccName x) (toIfaceType ext ty) (map (toIfaceAlt ext) as) toIfaceExpr ext (Let b e) = IfaceLet (toIfaceBind ext b) (toIfaceExpr ext e) toIfaceExpr ext (Note n e) = IfaceNote (toIfaceNote ext n) (toIfaceExpr ext e) @@ -733,9 +772,11 @@ eqIfDecl d1@(IfaceData {}) d2@(IfaceData {}) ifVrcs d1 == ifVrcs d2 && ifGeneric d1 == ifGeneric d2) &&& eqWith (ifTyVars d1) (ifTyVars d2) (\ env -> - eq_ifContext env (ifCtxt d1) (ifCtxt d2) &&& - eq_hsCD env (ifCons d1) (ifCons d2) + eq_hsCD env (ifCons d1) (ifCons d2) ) + -- The type variables of the data type do not scope + -- over the constructors (any more), but they do scope + -- over the stupid context in the IfaceConDecls eqIfDecl d1@(IfaceSyn {}) d2@(IfaceSyn {}) = bool (ifName d1 == ifName d2) &&& @@ -774,17 +815,30 @@ eqIfRule (IfaceRule n1 a1 bs1 f1 es1 rhs1) eq_ifaceExpr env rhs1 rhs2) eqIfRule _ _ = NotEqual -eq_hsCD env (IfDataTyCon c1) (IfDataTyCon c2) = eqListBy (eq_ConDecl env) c1 c2 +eq_hsCD env (IfDataTyCon st1 c1) (IfDataTyCon st2 c2) + = eqMaybeBy (eq_ifContext env) st1 st2 &&& + eqListBy (eq_ConDecl env) c1 c2 + eq_hsCD env (IfNewTyCon c1) (IfNewTyCon c2) = eq_ConDecl env c1 c2 eq_hsCD env IfAbstractTyCon IfAbstractTyCon = Equal eq_hsCD env d1 d2 = NotEqual -eq_ConDecl env (IfaceConDecl n1 inf1 tvs1 cxt1 args1 ss1 lbls1) - (IfaceConDecl n2 inf2 tvs2 cxt2 args2 ss2 lbls2) - = bool (n1 == n2 && inf1 == inf2 && ss1 == ss2 && lbls1 == lbls2) &&& - eq_ifTvBndrs env tvs1 tvs2 (\ env -> - eq_ifContext env cxt1 cxt2 &&& - eq_ifTypes env args1 args2) +eq_ConDecl env c1@(IfVanillaCon {}) c2@(IfVanillaCon {}) + = bool (ifConOcc c1 == ifConOcc c2 && + ifConInfix c1 == ifConInfix c2 && + ifConStricts c1 == ifConStricts c2 && + ifConFields c1 == ifConFields c2) &&& + eq_ifTypes env (ifConArgTys c1) (ifConArgTys c2) + +eq_ConDecl env c1@(IfGadtCon {}) c2@(IfGadtCon {}) + = bool (ifConOcc c1 == ifConOcc c2 && + ifConStricts c1 == ifConStricts c2) &&& + eq_ifTvBndrs env (ifConTyVars c1) (ifConTyVars c2) (\ env -> + eq_ifContext env (ifConCtxt c1) (ifConCtxt c2) &&& + eq_ifTypes env (ifConResTys c1) (ifConResTys c2) &&& + eq_ifTypes env (ifConArgTys c1) (ifConArgTys c2)) + +eq_ConDecl env c1 c2 = NotEqual eq_hsFD env (ns1,ms1) (ns2,ms2) = eqListBy (eqIfOcc env) ns1 ns2 &&& eqListBy (eqIfOcc env) ms1 ms2 @@ -819,8 +873,9 @@ eq_ifaceExpr env (IfaceLam b1 body1) (IfaceLam b2 body2) = eq_ifBndr env b1 b2 eq_ifaceExpr env (IfaceApp f1 a1) (IfaceApp f2 a2) = eq_ifaceExpr env f1 f2 &&& eq_ifaceExpr env a1 a2 eq_ifaceExpr env (IfaceNote n1 r1) (IfaceNote n2 r2) = eq_ifaceNote env n1 n2 &&& eq_ifaceExpr env r1 r2 -eq_ifaceExpr env (IfaceCase s1 b1 as1) (IfaceCase s2 b2 as2) +eq_ifaceExpr env (IfaceCase s1 b1 ty1 as1) (IfaceCase s2 b2 ty2 as2) = eq_ifaceExpr env s1 s2 &&& + eq_ifType env ty1 ty2 &&& eq_ifNakedBndr env b1 b2 (\env -> eqListBy (eq_ifaceAlt env) as1 as2) where eq_ifaceAlt env (c1,bs1,r1) (c2,bs2,r2) diff --git a/ghc/compiler/iface/IfaceType.lhs b/ghc/compiler/iface/IfaceType.lhs index e5d91dea13..b771e5a403 100644 --- a/ghc/compiler/iface/IfaceType.lhs +++ b/ghc/compiler/iface/IfaceType.lhs @@ -30,7 +30,7 @@ import TyCon ( TyCon, isTupleTyCon, tyConArity, tupleTyConBoxity ) import Var ( isId, tyVarKind, idType ) import TysWiredIn ( listTyConName, parrTyConName, tupleTyCon, intTyConName, charTyConName, boolTyConName ) import OccName ( OccName ) -import Name ( Name, getName, getOccName, nameModuleName, nameOccName, isInternalName ) +import Name ( Name, getName, getOccName, nameModuleName, nameOccName ) import Module ( ModuleName ) import BasicTypes ( IPName(..), Arity, Version, mapIPName, tupleParens, Boxity ) import Outputable diff --git a/ghc/compiler/iface/LoadIface.lhs b/ghc/compiler/iface/LoadIface.lhs index d2a0f48907..62e31d4605 100644 --- a/ghc/compiler/iface/LoadIface.lhs +++ b/ghc/compiler/iface/LoadIface.lhs @@ -22,15 +22,14 @@ import CmdLineOpts ( DynFlags( verbosity ), DynFlag( Opt_IgnoreInterfacePragmas opt_InPackage ) import Parser ( parseIface ) -import IfaceSyn ( IfaceDecl(..), IfaceConDecls(..), IfaceConDecl(..), IfaceClassOp(..), +import IfaceSyn ( IfaceDecl(..), IfaceConDecl(..), IfaceClassOp(..), IfaceConDecls(..), IfaceInst(..), IfaceRule(..), IfaceExpr(..), IfaceTyCon(..), IfaceIdInfo(..), - IfaceType(..), IfacePredType(..), IfaceExtName, visibleIfConDecls, mkIfaceExtName ) + IfaceType(..), IfacePredType(..), IfaceExtName, mkIfaceExtName ) import IfaceEnv ( newGlobalBinder, lookupIfaceExt, lookupIfaceTc ) -import HscTypes ( HscEnv(..), ModIface(..), TyThing, emptyModIface, EpsStats(..), addEpsInStats, +import HscTypes ( ModIface(..), TyThing, emptyModIface, EpsStats(..), addEpsInStats, ExternalPackageState(..), PackageTypeEnv, emptyTypeEnv, lookupIfaceByModName, emptyPackageIfaceTable, - IsBootInterface, mkIfaceFixCache, mkTypeEnv, - Gated, implicitTyThings, + IsBootInterface, mkIfaceFixCache, Gated, implicitTyThings, addRulesToPool, addInstsToPool ) @@ -40,7 +39,7 @@ import Type ( funTyCon ) import TcRnMonad import PrelNames ( gHC_PRIM_Name ) -import PrelInfo ( ghcPrimExports, wiredInThings ) +import PrelInfo ( ghcPrimExports ) import PrelRules ( builtinRules ) import Rules ( emptyRuleBase ) import InstEnv ( emptyInstEnv ) @@ -50,7 +49,7 @@ import NameEnv import MkId ( seqId ) import Packages ( basePackage ) import Module ( Module, ModuleName, ModLocation(ml_hi_file), - moduleName, isHomeModule, emptyModuleEnv, moduleEnvElts, + moduleName, isHomeModule, emptyModuleEnv, extendModuleEnv, lookupModuleEnvByName, moduleUserString ) import OccName ( OccName, mkOccEnv, lookupOccEnv, mkClassTyConOcc, mkClassDataConOcc, @@ -330,26 +329,30 @@ ifaceDeclSubBndrs (IfaceClass {ifCtxt = sc_ctxt, ifName = cls_occ, ifSigs = sigs ifaceDeclSubBndrs (IfaceData {ifCons = IfAbstractTyCon}) = [] -ifaceDeclSubBndrs (IfaceData {ifCons = IfNewTyCon (IfaceConDecl con_occ _ _ _ _ _ fields)}) +-- Newtype +ifaceDeclSubBndrs (IfaceData {ifCons = IfNewTyCon (IfVanillaCon { ifConOcc = con_occ, + ifConFields = fields})}) = fields ++ [con_occ, mkDataConWrapperOcc con_occ] -- Wrapper, no worker; see MkId.mkDataConIds -ifaceDeclSubBndrs (IfaceData {ifCons = IfDataTyCon cons}) +ifaceDeclSubBndrs (IfaceData {ifCons = IfDataTyCon _ cons}) = nub (concatMap fld_occs cons) -- Eliminate duplicate fields ++ concatMap dc_occs cons where - fld_occs (IfaceConDecl _ _ _ _ _ _ fields) = fields - dc_occs (IfaceConDecl con_occ _ _ _ _ strs _) + fld_occs (IfVanillaCon { ifConFields = fields }) = fields + fld_occs (IfGadtCon {}) = [] + dc_occs con_decl | has_wrapper = [con_occ, work_occ, wrap_occ] | otherwise = [con_occ, work_occ] where + con_occ = ifConOcc con_decl + strs = ifConStricts con_decl wrap_occ = mkDataConWrapperOcc con_occ work_occ = mkDataConWorkerOcc con_occ has_wrapper = any isMarkedStrict strs -- See MkId.mkDataConIds (sigh) -- ToDo: may miss strictness in existential dicts -ifaceDeclSubBndrs _other = [] - +ifaceDeclSubBndrs _other = [] ----------------------------------------------------- -- Loading instance decls diff --git a/ghc/compiler/iface/MkIface.lhs b/ghc/compiler/iface/MkIface.lhs index c7a71b7098..e8fbeb0fd4 100644 --- a/ghc/compiler/iface/MkIface.lhs +++ b/ghc/compiler/iface/MkIface.lhs @@ -191,7 +191,7 @@ import HscTypes ( ModIface(..), TyThing(..), Dependencies(..), FixItem(..), mkIfaceDepCache, mkIfaceFixCache, mkIfaceVerCache, typeEnvElts, - Avails, AvailInfo, GenAvailInfo(..), availName, + GenAvailInfo(..), availName, ExternalPackageState(..), Usage(..), IsBootInterface, Deprecs(..), IfaceDeprecs, Deprecations, @@ -209,10 +209,9 @@ import OccName ( OccName, OccEnv, mkOccEnv, lookupOccEnv, emptyOccEnv, extendOc extendOccSet, extendOccSetList, isEmptyOccSet, intersectOccSet, intersectsOccSet, occNameFS, isTcOcc ) -import TyCon ( visibleDataCons, tyConDataCons, isNewTyCon, newTyConRep ) +import TyCon ( tyConDataCons, isNewTyCon, newTyConRep ) import Class ( classSelIds ) import DataCon ( dataConName, dataConFieldLabels ) -import FieldLabel ( fieldLabelName ) import Module ( Module, ModuleName, moduleNameFS, moduleName, isHomeModule, ModLocation(..), mkSysModuleNameFS, moduleUserString, ModuleEnv, emptyModuleEnv, lookupModuleEnv, @@ -358,9 +357,7 @@ mustExposeThing exports (ATyCon tc) -- can only do that if it can "see" the newtype representation where exported_data_con con - = any (`elemNameSet` exports) (dataConName con : field_names) - where - field_names = map fieldLabelName (dataConFieldLabels con) + = any (`elemNameSet` exports) (dataConName con : dataConFieldLabels con) mustExposeThing exports (AClass cls) = any exported_class_op (classSelIds cls) @@ -535,7 +532,7 @@ addVersionInfo (Just old_iface@(ModIface { mi_mod_vers = old_mod_vers, eq_ind_occs [op | IfaceClassOp op _ _ <- sigs] eq_indirects (IfaceData {ifName = tc_occ, ifCons = cons}) = same_insts tc_occ &&& same_fixity tc_occ &&& -- The TyCon can have a fixity too - eq_ind_occs [occ | IfaceConDecl occ _ _ _ _ _ _ <- visibleIfConDecls cons] + eq_ind_occs (map ifConOcc (visibleIfConDecls cons)) eq_indirects other = Equal -- Synonyms and foreign declarations eq_ind_occ :: OccName -> IfaceEq -- For class ops and Ids; check fixity and rules @@ -766,7 +763,6 @@ mkIfaceExports exports (unitFM avail_fs avail) where occ = nameOccName name - occ_fs = occNameFS occ mod_fs = moduleNameFS (nameModuleName name) avail | Just p <- nameParent_maybe name = AvailTC (nameOccName p) [occ] | isTcOcc occ = AvailTC occ [occ] diff --git a/ghc/compiler/iface/TcIface.lhs b/ghc/compiler/iface/TcIface.lhs index 1d08095f26..2ca88bad3b 100644 --- a/ghc/compiler/iface/TcIface.lhs +++ b/ghc/compiler/iface/TcIface.lhs @@ -26,10 +26,9 @@ import TypeRep ( Type(..), PredType(..) ) import TyCon ( TyCon, tyConName ) import HscTypes ( ExternalPackageState(..), EpsStats(..), PackageInstEnv, HscEnv, TyThing(..), implicitTyThings, tyThingClass, tyThingTyCon, - ModIface(..), ModDetails(..), InstPool, ModGuts, - TypeEnv, mkTypeEnv, extendTypeEnv, extendTypeEnvList, - lookupTypeEnv, lookupType, typeEnvIds, - RulePool ) + ModIface(..), ModDetails(..), ModGuts, + mkTypeEnv, extendTypeEnv, + lookupTypeEnv, lookupType, typeEnvIds ) import InstEnv ( extendInstEnv ) import CoreSyn import PprCore ( pprIdRules ) @@ -46,13 +45,12 @@ import IdInfo ( IdInfo, CafInfo(..), WorkerInfo(..), setArityInfo, setInlinePragInfo, setCafInfo, vanillaIdInfo, newStrictnessInfo ) import Class ( Class ) -import TyCon ( tyConDataCons, tyConTyVars, isTupleTyCon, mkForeignTyCon ) -import DataCon ( DataCon, dataConWorkId, dataConExistentialTyVars, dataConArgTys ) -import TysWiredIn ( intTyCon, boolTyCon, charTyCon, listTyCon, parrTyCon, - tupleTyCon, tupleCon ) +import TyCon ( tyConDataCons, isTupleTyCon, mkForeignTyCon ) +import DataCon ( DataCon, dataConWorkId, dataConTyVars, dataConArgTys, isVanillaDataCon ) +import TysWiredIn ( tupleCon, tupleTyCon, listTyCon, intTyCon, boolTyCon, charTyCon, parrTyCon ) import Var ( TyVar, mkTyVar, tyVarKind ) -import Name ( Name, NamedThing(..), nameModuleName, nameModule, nameOccName, nameIsLocalOrFrom, - isWiredInName, wiredInNameTyThing_maybe, nameParent, nameParent_maybe ) +import Name ( Name, nameModuleName, nameModule, nameIsLocalOrFrom, + isWiredInName, wiredInNameTyThing_maybe, nameParent ) import NameEnv import OccName ( OccName ) import Module ( Module, ModuleName, moduleName ) @@ -60,11 +58,7 @@ import UniqSupply ( initUs_ ) import Outputable import SrcLoc ( noSrcLoc ) import Util ( zipWithEqual, dropList, equalLength, zipLazy ) -import Maybes ( expectJust ) import CmdLineOpts ( DynFlag(..) ) - -import UniqFM (sizeUFM) - \end{code} This module takes @@ -262,35 +256,22 @@ tcIfaceDecl (IfaceId {ifName = occ_name, ifType = iface_type, ifIdInfo = info}) ; return (AnId (mkVanillaGlobal name ty info)) } tcIfaceDecl (IfaceData {ifName = occ_name, - ifTyVars = tv_bndrs, ifCtxt = rdr_ctxt, + ifTyVars = tv_bndrs, ifCons = rdr_cons, ifVrcs = arg_vrcs, ifRec = is_rec, ifGeneric = want_generic }) = do { tc_name <- lookupIfaceTop occ_name ; bindIfaceTyVars tv_bndrs $ \ tyvars -> do - { traceIf (text "tcIfaceDecl" <+> ppr rdr_ctxt) - - ; ctxt <- forkM (ptext SLIT("Ctxt of data decl") <+> ppr tc_name) $ - tcIfaceCtxt rdr_ctxt - -- The reason for laziness here is to postpone - -- looking at the context, because the class may not - -- be in the type envt yet. E.g. - -- class Real a where { toRat :: a -> Ratio Integer } - -- data (Real a) => Ratio a = ... - -- We suck in the decl for Real, and type check it, which sucks - -- in the data type Ratio; but we must postpone typechecking the - -- context - - ; tycon <- fixM ( \ tycon -> do - { cons <- tcIfaceDataCons tycon tyvars ctxt rdr_cons - ; tycon <- buildAlgTyCon tc_name tyvars ctxt cons + { tycon <- fixM ( \ tycon -> do + { cons <- tcIfaceDataCons tycon tyvars rdr_cons + ; tycon <- buildAlgTyCon tc_name tyvars cons arg_vrcs is_rec want_generic ; return tycon }) ; traceIf (text "tcIfaceDecl4" <+> ppr tycon) ; return (ATyCon tycon) - } } + }} tcIfaceDecl (IfaceSyn {ifName = occ_name, ifTyVars = tv_bndrs, ifSynRhs = rdr_rhs_ty, ifVrcs = arg_vrcs}) @@ -330,30 +311,58 @@ tcIfaceDecl (IfaceForeign {ifName = rdr_name, ifExtName = ext_name}) ; return (ATyCon (mkForeignTyCon name ext_name liftedTypeKind 0 [])) } -tcIfaceDataCons tycon tyvars ctxt if_cons +tcIfaceDataCons tycon tc_tyvars if_cons = case if_cons of - IfAbstractTyCon -> return mkAbstractTyConRhs - IfDataTyCon cons -> do { data_cons <- mappM tc_con_decl cons - ; return (mkDataTyConRhs data_cons) } - IfNewTyCon con -> do { data_con <- tc_con_decl con - ; return (mkNewTyConRhs data_con) } + IfAbstractTyCon -> return mkAbstractTyConRhs + IfDataTyCon mb_ctxt cons -> do { mb_theta <- tc_ctxt mb_ctxt + ; data_cons <- mappM tc_con_decl cons + ; return (mkDataTyConRhs mb_theta data_cons) } + IfNewTyCon con -> do { data_con <- tc_con_decl con + ; return (mkNewTyConRhs tycon data_con) } where - tc_con_decl (IfaceConDecl occ is_infix ex_tvs ex_ctxt args stricts field_lbls) - = bindIfaceTyVars ex_tvs $ \ ex_tyvars -> do - { name <- lookupIfaceTop occ - ; ex_theta <- tcIfaceCtxt ex_ctxt -- Laziness seems not worth the bother here + tc_ctxt Nothing = return Nothing + tc_ctxt (Just ctxt) = do { theta <- tcIfaceCtxt ctxt; return (Just theta) } + + tc_con_decl (IfVanillaCon { ifConOcc = occ, ifConInfix = is_infix, ifConArgTys = args, + ifConStricts = stricts, ifConFields = field_lbls}) + = do { name <- lookupIfaceTop occ + -- Read the argument types, but lazily to avoid faulting in + -- the component types unless they are really needed + ; arg_tys <- forkM (mk_doc name) (mappM tcIfaceType args) + ; lbl_names <- mappM lookupIfaceTop field_lbls + ; buildDataCon name is_infix True {- Vanilla -} + stricts lbl_names + tc_tyvars [] arg_tys tycon + (mkTyVarTys tc_tyvars) -- Vanilla => we know result tys + } + + tc_con_decl (IfGadtCon { ifConTyVars = con_tvs, + ifConOcc = occ, ifConCtxt = ctxt, + ifConArgTys = args, ifConResTys = ress, + ifConStricts = stricts}) + = bindIfaceTyVars con_tvs $ \ con_tyvars -> do + { name <- lookupIfaceTop occ + ; theta <- tcIfaceCtxt ctxt -- Laziness seems not worth the bother here + -- At one stage I thought that this context checking *had* + -- to be lazy, because of possible mutual recursion between the + -- type and the classe: + -- E.g. + -- class Real a where { toRat :: a -> Ratio Integer } + -- data (Real a) => Ratio a = ... + -- But now I think that the laziness in checking class ops breaks + -- the loop, so no laziness needed -- Read the argument types, but lazily to avoid faulting in -- the component types unless they are really needed - ; arg_tys <- forkM (mk_doc name args) (mappM tcIfaceType args) ; - - ; lbl_names <- mappM lookupIfaceTop field_lbls + ; arg_tys <- forkM (mk_doc name) (mappM tcIfaceType args) + ; res_tys <- forkM (mk_doc name) (mappM tcIfaceType ress) - ; buildDataCon name is_infix stricts lbl_names - tyvars ctxt ex_tyvars ex_theta - arg_tys tycon + ; buildDataCon name False {- Not infix -} False {- Not vanilla -} + stricts [{- No fields -}] + con_tyvars theta + arg_tys tycon res_tys } - mk_doc con_name args = ptext SLIT("Constructor") <+> sep [ppr con_name, ppr args] + mk_doc con_name = ptext SLIT("Constructor") <+> ppr con_name \end{code} @@ -626,7 +635,8 @@ tcIfaceExpr (IfaceApp fun arg) tcIfaceExpr arg `thenM` \ arg' -> returnM (App fun' arg') -tcIfaceExpr (IfaceCase scrut case_bndr alts) +-- gaw 2004 +tcIfaceExpr (IfaceCase scrut case_bndr ty alts) = tcIfaceExpr scrut `thenM` \ scrut' -> newIfaceName case_bndr `thenM` \ case_bndr_name -> let @@ -641,7 +651,8 @@ tcIfaceExpr (IfaceCase scrut case_bndr alts) in extendIfaceIdEnv [case_bndr'] $ mappM (tcIfaceAlt tc_app) alts `thenM` \ alts' -> - returnM (Case scrut' case_bndr' alts') + tcIfaceType ty `thenM` \ ty' -> + returnM (Case scrut' case_bndr' ty' alts') tcIfaceExpr (IfaceLet (IfaceNonRec bndr rhs) body) = tcIfaceExpr rhs `thenM` \ rhs' -> @@ -683,45 +694,42 @@ tcIfaceAlt _ (IfaceLitAlt lit, names, rhs) -- by the fact that we omit type annotations because we can -- work them out. True enough, but its not that easy! tcIfaceAlt (tycon, inst_tys) (IfaceDataAlt data_occ, arg_occs, rhs) - = let - tycon_mod = nameModuleName (tyConName tycon) - in - tcIfaceDataCon (ExtPkg tycon_mod data_occ) `thenM` \ con -> - newIfaceNames arg_occs `thenM` \ arg_names -> - let - ex_tyvars = dataConExistentialTyVars con - main_tyvars = tyConTyVars tycon - ex_tyvars' = [mkTyVar name (tyVarKind tv) | (name,tv) <- arg_names `zip` ex_tyvars] - ex_tys' = mkTyVarTys ex_tyvars' - arg_tys = dataConArgTys con (inst_tys ++ ex_tys') - id_names = dropList ex_tyvars arg_names - arg_ids -#ifdef DEBUG - | not (equalLength id_names arg_tys) - = pprPanic "tcIfaceAlts" (ppr (con, arg_names, rhs) $$ - (ppr main_tyvars <+> ppr ex_tyvars) $$ - ppr arg_tys) - | otherwise -#endif - = zipWithEqual "tcIfaceAlts" mkLocalId id_names arg_tys - in - ASSERT2( con `elem` tyConDataCons tycon && equalLength inst_tys main_tyvars, - ppr con $$ ppr tycon $$ ppr (tyConDataCons tycon) $$ ppr arg_tys $$ ppr main_tyvars ) - extendIfaceTyVarEnv ex_tyvars' $ - extendIfaceIdEnv arg_ids $ - tcIfaceExpr rhs `thenM` \ rhs' -> - returnM (DataAlt con, ex_tyvars' ++ arg_ids, rhs') + = do { let tycon_mod = nameModuleName (tyConName tycon) + ; con <- tcIfaceDataCon (ExtPkg tycon_mod data_occ) + ; ASSERT2( con `elem` tyConDataCons tycon, + ppr con $$ ppr tycon $$ ppr (tyConDataCons tycon) ) + + if isVanillaDataCon con then + tcVanillaAlt con inst_tys arg_occs rhs + else + do { -- General case + arg_names <- newIfaceNames arg_occs + ; let tyvars = [ mkTyVar name (tyVarKind tv) + | (name,tv) <- arg_names `zip` dataConTyVars con] + arg_tys = dataConArgTys con (mkTyVarTys tyvars) + id_names = dropList tyvars arg_names + arg_ids = ASSERT2( equalLength id_names arg_tys, + ppr (con, arg_names, rhs) $$ ppr tyvars $$ ppr arg_tys ) + zipWith mkLocalId id_names arg_tys + + ; rhs' <- extendIfaceTyVarEnv tyvars $ + extendIfaceIdEnv arg_ids $ + tcIfaceExpr rhs + ; return (DataAlt con, tyvars ++ arg_ids, rhs') }} tcIfaceAlt (tycon, inst_tys) (IfaceTupleAlt boxity, arg_occs, rhs) - = newIfaceNames arg_occs `thenM` \ arg_names -> - let - [con] = tyConDataCons tycon - arg_ids = zipWithEqual "tcIfaceAlts" mkLocalId arg_names inst_tys - in - ASSERT( isTupleTyCon tycon ) - extendIfaceIdEnv arg_ids $ - tcIfaceExpr rhs `thenM` \ rhs' -> - returnM (DataAlt con, arg_ids, rhs') + = ASSERT( isTupleTyCon tycon ) + do { let [data_con] = tyConDataCons tycon + ; tcVanillaAlt data_con inst_tys arg_occs rhs } + +tcVanillaAlt data_con inst_tys arg_occs rhs + = do { arg_names <- newIfaceNames arg_occs + ; let arg_tys = dataConArgTys data_con inst_tys + ; let arg_ids = ASSERT2( equalLength arg_names arg_tys, + ppr data_con <+> ppr inst_tys <+> ppr arg_occs $$ ppr rhs ) + zipWith mkLocalId arg_names arg_tys + ; rhs' <- extendIfaceIdEnv arg_ids (tcIfaceExpr rhs) + ; returnM (DataAlt data_con, arg_ids, rhs') } \end{code} diff --git a/ghc/compiler/main/CodeOutput.lhs b/ghc/compiler/main/CodeOutput.lhs index 7732497a64..edf56d588e 100644 --- a/ghc/compiler/main/CodeOutput.lhs +++ b/ghc/compiler/main/CodeOutput.lhs @@ -40,7 +40,6 @@ import ListSetOps ( removeDupsEq ) import Maybes ( firstJust ) import Directory ( doesFileExist ) -import Data.List ( intersperse ) import Monad ( when ) import IO \end{code} diff --git a/ghc/compiler/main/DriverMkDepend.hs b/ghc/compiler/main/DriverMkDepend.hs index 87bdcd3bb8..b376102e8c 100644 --- a/ghc/compiler/main/DriverMkDepend.hs +++ b/ghc/compiler/main/DriverMkDepend.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- $Id: DriverMkDepend.hs,v 1.32 2004/06/24 09:41:11 simonmar Exp $ +-- $Id: DriverMkDepend.hs,v 1.33 2004/09/30 10:37:10 simonpj Exp $ -- -- GHC Driver -- diff --git a/ghc/compiler/main/DriverPhases.hs b/ghc/compiler/main/DriverPhases.hs index 89a610021b..a81d93e30f 100644 --- a/ghc/compiler/main/DriverPhases.hs +++ b/ghc/compiler/main/DriverPhases.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- $Id: DriverPhases.hs,v 1.29 2004/08/13 13:06:57 simonmar Exp $ +-- $Id: DriverPhases.hs,v 1.30 2004/09/30 10:37:11 simonpj Exp $ -- -- GHC Driver -- diff --git a/ghc/compiler/main/DriverUtil.hs b/ghc/compiler/main/DriverUtil.hs index b8796c1244..f1d61e4acf 100644 --- a/ghc/compiler/main/DriverUtil.hs +++ b/ghc/compiler/main/DriverUtil.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- $Id: DriverUtil.hs,v 1.43 2004/08/13 13:07:02 simonmar Exp $ +-- $Id: DriverUtil.hs,v 1.44 2004/09/30 10:37:11 simonpj Exp $ -- -- Utils for the driver -- diff --git a/ghc/compiler/main/HscMain.lhs b/ghc/compiler/main/HscMain.lhs index 8d2fa59419..e269af763e 100644 --- a/ghc/compiler/main/HscMain.lhs +++ b/ghc/compiler/main/HscMain.lhs @@ -37,11 +37,12 @@ import Var ( Id ) import CoreLint ( lintUnfolding ) import DsMeta ( templateHaskellNames ) import BasicTypes ( Fixity ) +import SrcLoc ( SrcLoc, noSrcLoc ) #endif import RdrName ( RdrName ) import HsSyn ( HsModule ) -import SrcLoc ( SrcLoc, noSrcLoc, Located(..) ) +import SrcLoc ( Located(..) ) import StringBuffer ( hGetStringBuffer ) import Parser import Lexer ( P(..), ParseResult(..), mkPState ) diff --git a/ghc/compiler/main/HscStats.lhs b/ghc/compiler/main/HscStats.lhs index 170175ab07..85e692b57b 100644 --- a/ghc/compiler/main/HscStats.lhs +++ b/ghc/compiler/main/HscStats.lhs @@ -99,9 +99,9 @@ ppSourceStats short (L _ (HsModule _ exports imports ldecls _)) (inst_method_ds, method_specs, method_inlines) = foldr add3 (0,0,0) (map inst_info inst_decls) - count_bind (PatBind (L _ (VarPat n)) r) = (1,0) - count_bind (PatBind p r) = (0,1) - count_bind (FunBind f _ m) = (0,1) + count_bind (PatBind (L _ (VarPat n)) r _) = (1,0) + count_bind (PatBind p r _) = (0,1) + count_bind (FunBind f _ m) = (0,1) count_sigs sigs = foldr add4 (0,0,0,0) (map sig_info sigs) diff --git a/ghc/compiler/main/HscTypes.lhs b/ghc/compiler/main/HscTypes.lhs index 5f1ce2d272..78a407f474 100644 --- a/ghc/compiler/main/HscTypes.lhs +++ b/ghc/compiler/main/HscTypes.lhs @@ -68,7 +68,7 @@ import Name ( Name, NamedThing, getName, nameOccName, nameModule, nameModuleNam import NameEnv import NameSet import OccName ( OccName, OccEnv, lookupOccEnv, mkOccEnv, emptyOccEnv, - extendOccEnv, foldOccEnv ) + extendOccEnv ) import Module import InstEnv ( InstEnv, DFunId ) import Rules ( RuleBase ) @@ -77,7 +77,7 @@ import Id ( Id ) import Type ( TyThing(..) ) import Class ( Class, classSelIds, classTyCon ) -import TyCon ( TyCon, isClassTyCon, tyConSelIds, tyConDataCons ) +import TyCon ( TyCon, tyConSelIds, tyConDataCons ) import DataCon ( dataConImplicitIds ) import Packages ( PackageName ) import CmdLineOpts ( DynFlags ) diff --git a/ghc/compiler/main/Main.hs b/ghc/compiler/main/Main.hs index 7a2ae0c67f..336cbee22d 100644 --- a/ghc/compiler/main/Main.hs +++ b/ghc/compiler/main/Main.hs @@ -1,7 +1,7 @@ {-# OPTIONS -fno-warn-incomplete-patterns -optc-DNON_POSIX_SOURCE #-} ----------------------------------------------------------------------------- --- $Id: Main.hs,v 1.138 2004/08/13 13:07:05 simonmar Exp $ +-- $Id: Main.hs,v 1.139 2004/09/30 10:37:17 simonpj Exp $ -- -- GHC Driver program -- diff --git a/ghc/compiler/main/TidyPgm.lhs b/ghc/compiler/main/TidyPgm.lhs index aaedea479b..01cdd0f0a8 100644 --- a/ghc/compiler/main/TidyPgm.lhs +++ b/ghc/compiler/main/TidyPgm.lhs @@ -651,7 +651,8 @@ cafRefs p (Lit l) = fastBool False cafRefs p (App f a) = fastOr (cafRefs p f) (cafRefs p) a cafRefs p (Lam x e) = cafRefs p e cafRefs p (Let b e) = fastOr (cafRefss p (rhssOfBind b)) (cafRefs p) e -cafRefs p (Case e bndr alts) = fastOr (cafRefs p e) (cafRefss p) (rhssOfAlts alts) +-- gaw 2004 +cafRefs p (Case e bndr _ alts) = fastOr (cafRefs p e) (cafRefss p) (rhssOfAlts alts) cafRefs p (Note n e) = cafRefs p e cafRefs p (Type t) = fastBool False diff --git a/ghc/compiler/ndpFlatten/Flattening.hs b/ghc/compiler/ndpFlatten/Flattening.hs index a28be20911..393762fe40 100644 --- a/ghc/compiler/ndpFlatten/Flattening.hs +++ b/ghc/compiler/ndpFlatten/Flattening.hs @@ -285,11 +285,13 @@ vectorise (Let bind body) = (vbody, vbodyTy) <- vectorise body return ((Let vbind vbody), vbodyTy) -vectorise (Case expr b alts) = +-- gaw 2004 +vectorise (Case expr b ty alts) = do (vexpr, vexprTy) <- vectorise expr valts <- mapM vectorise' alts - return (Case vexpr (setIdType b vexprTy) (map fst valts), snd (head valts)) + let res_ty = snd (head valts) + return (Case vexpr (setIdType b vexprTy) res_ty (map fst valts), res_ty) where vectorise' (con, bs, expr) = do (vexpr, vexprTy) <- vectorise expr @@ -441,7 +443,8 @@ lift (Let (Rec binds) expr2) = -- otherwise (a) compute index vector for simpleAlts (for def permute -- later on -- (b) -lift cExpr@(Case expr b alts) = +-- gaw 2004 FIX? +lift cExpr@(Case expr b _ alts) = do (lExpr, _) <- lift expr lb <- liftBinderType b -- lift alt-expression @@ -802,7 +805,8 @@ showCoreExpr (Let bnds expr) = where showBinds (NonRec b e) = showBind (b,e) showBinds (Rec bnds) = concat (map showBind bnds) showBind (b,e) = " b = " ++ (showCoreExpr e)++ "\n" -showCoreExpr (Case ex b alts) = +-- gaw 2004 FIX? +showCoreExpr (Case ex b ty alts) = "Case b = " ++ (showCoreExpr ex) ++ " of \n" ++ (showAlts alts) where showAlts _ = "" showCoreExpr (Note _ ex) = "Note n " ++ (showCoreExpr ex) diff --git a/ghc/compiler/ndpFlatten/NDPCoreUtils.hs b/ghc/compiler/ndpFlatten/NDPCoreUtils.hs index 1bf74b4866..193f6028aa 100644 --- a/ghc/compiler/ndpFlatten/NDPCoreUtils.hs +++ b/ghc/compiler/ndpFlatten/NDPCoreUtils.hs @@ -163,12 +163,13 @@ substIdEnv env (Let (Rec bnds) expr) = newExpr = substIdEnv newEnv expr substBnd (b,e) = (b, substIdEnv newEnv e) in Let (Rec (map substBnd bnds)) newExpr -substIdEnv env (Case expr b alts) = - Case (substIdEnv newEnv expr) b (map substAlt alts) +-- gaw 2004 +substIdEnv env (Case expr b ty alts) = + Case (substIdEnv newEnv expr) b ty (map substAlt alts) where newEnv = delVarEnv env b substAlt (c, bnds, expr) = (c, bnds, substIdEnv (delVarEnvList env bnds) expr) substIdEnv env (Note n expr) = Note n (substIdEnv env expr) -substIdEnv env e@(Type t) = e
\ No newline at end of file +substIdEnv env e@(Type t) = e diff --git a/ghc/compiler/ndpFlatten/PArrAnal.hs b/ghc/compiler/ndpFlatten/PArrAnal.hs index 46643d1a05..b4d084364b 100644 --- a/ghc/compiler/ndpFlatten/PArrAnal.hs +++ b/ghc/compiler/ndpFlatten/PArrAnal.hs @@ -75,7 +75,8 @@ arrUsage (Let (Rec bnds) expr) = t2 = arrUsage expr in if isArrayUsage t1 then Array else t2 -arrUsage (Case expr b alts) = +-- gaw 2004 +arrUsage (Case expr b _ alts) = let t1 = arrUsage expr t2 = scanType (map (arrUsage . (\ (_,_,x) -> x)) alts) diff --git a/ghc/compiler/parser/Parser.y.pp b/ghc/compiler/parser/Parser.y.pp index 83b299a7b8..058f582902 100644 --- a/ghc/compiler/parser/Parser.y.pp +++ b/ghc/compiler/parser/Parser.y.pp @@ -333,6 +333,8 @@ ifacedecl :: { HsDecl RdrName } { let (tc,tvs) = $2 in TyClD (TySynonym tc tvs $4) } | 'data' tycl_hdr constrs -- No deriving in hi-boot { TyClD (mkTyData DataType (unLoc $2) (reverse (unLoc $3)) Nothing) } + | 'data' tycl_hdr 'where' gadt_constrlist + { TyClD (mkTyData DataType (unLoc $2) (reverse (unLoc $4)) Nothing) } | 'newtype' tycl_hdr -- Constructor is optional { TyClD (mkTyData NewType (unLoc $2) [] Nothing) } | 'newtype' tycl_hdr '=' newconstr @@ -455,6 +457,10 @@ tycl_decl :: { LTyClDecl RdrName } { L (comb4 $1 $2 $3 $4) (mkTyData DataType (unLoc $2) (reverse (unLoc $3)) (unLoc $4)) } + | 'data' tycl_hdr 'where' gadt_constrlist -- No deriving for GADTs + { L (comb4 $1 $2 $3 $4) + (mkTyData DataType (unLoc $2) (reverse (unLoc $4)) Nothing) } + | 'newtype' tycl_hdr '=' newconstr deriving { L (comb3 $1 $4 $5) (mkTyData NewType (unLoc $2) [$4] (unLoc $5)) } @@ -742,6 +748,10 @@ sig_vars :: { Located [Located RdrName] } ----------------------------------------------------------------------------- -- Types +strict_mark :: { Located HsBang } + : '!' { L1 HsStrict } + | '{-# UNPACK' '#-}' '!' { LL HsUnbox } + -- A ctype is a for-all type ctype :: { LHsType RdrName } : 'forall' tv_bndrs '.' ctype { LL $ mkExplicitHsForAllTy $2 (noLoc []) $4 } @@ -773,6 +783,7 @@ btype :: { LHsType RdrName } atype :: { LHsType RdrName } : gtycon { L1 (HsTyVar (unLoc $1)) } | tyvar { L1 (HsTyVar (unLoc $1)) } + | strict_mark atype { LL (HsBangTy (unLoc $1) $2) } | '(' type ',' comma_types1 ')' { LL $ HsTupleTy Boxed ($2:$4) } | '(#' comma_types1 '#)' { LL $ HsTupleTy Unboxed $2 } | '[' type ']' { LL $ HsListTy $2 } @@ -787,7 +798,7 @@ atype :: { LHsType RdrName } -- It's kept as a single type, with a MonoDictTy at the right -- hand corner, for convenience. inst_type :: { LHsType RdrName } - : ctype {% checkInstType $1 } + : sigtype {% checkInstType $1 } inst_types1 :: { [LHsType RdrName] } : inst_type { [$1] } @@ -841,11 +852,21 @@ akind :: { Kind } -- Datatype declarations newconstr :: { LConDecl RdrName } - : conid atype { LL $ ConDecl $1 [] (noLoc []) - (PrefixCon [(unbangedType $2)]) } + : conid atype { LL $ ConDecl $1 [] (noLoc []) (PrefixCon [$2]) } | conid '{' var '::' ctype '}' - { LL $ ConDecl $1 [] (noLoc []) - (RecCon [($3, (unbangedType $5))]) } + { LL $ ConDecl $1 [] (noLoc []) (RecCon [($3, $5)]) } + +gadt_constrlist :: { Located [LConDecl RdrName] } + : '{' gadt_constrs '}' { LL (unLoc $2) } + | vocurly gadt_constrs close { $2 } + +gadt_constrs :: { Located [LConDecl RdrName] } + : gadt_constrs ';' gadt_constr { LL ($3 : unLoc $1) } + | gadt_constr { L1 [$1] } + +gadt_constr :: { LConDecl RdrName } + : qcon '::' sigtype + { LL (GadtDecl $1 $3) } constrs :: { Located [LConDecl RdrName] } : {- empty; a GHC extension -} { noLoc [] } @@ -868,39 +889,24 @@ forall :: { Located [LHsTyVarBndr RdrName] } | {- empty -} { noLoc [] } constr_stuff :: { Located (Located RdrName, HsConDetails RdrName (LBangType RdrName)) } +-- We parse the constructor declaration +-- C t1 t2 +-- as a btype (treating C as a type constructor) and then convert C to be +-- a data constructor. Reason: it might continue like this: +-- C t1 t2 %: D Int +-- in which case C really would be a type constructor. We can't resolve this +-- ambiguity till we come across the constructor oprerator :% (or not, more usually) : btype {% mkPrefixCon $1 [] >>= return.LL } - | btype bang_atype satypes {% do { r <- mkPrefixCon $1 ($2 : unLoc $3); - return (L (comb3 $1 $2 $3) r) } } | oqtycon '{' '}' {% mkRecCon $1 [] >>= return.LL } | oqtycon '{' fielddecls '}' {% mkRecCon $1 $3 >>= return.LL } - | sbtype conop sbtype { LL ($2, InfixCon $1 $3) } - -bang_atype :: { LBangType RdrName } - : strict_mark atype { LL (BangType (unLoc $1) $2) } - -satypes :: { Located [LBangType RdrName] } - : atype satypes { LL (unbangedType $1 : unLoc $2) } - | bang_atype satypes { LL ($1 : unLoc $2) } - | {- empty -} { noLoc [] } - -sbtype :: { LBangType RdrName } - : btype { unbangedType $1 } - | strict_mark atype { LL (BangType (unLoc $1) $2) } + | btype conop btype { LL ($2, InfixCon $1 $3) } fielddecls :: { [([Located RdrName], LBangType RdrName)] } : fielddecl ',' fielddecls { unLoc $1 : $3 } | fielddecl { [unLoc $1] } fielddecl :: { Located ([Located RdrName], LBangType RdrName) } - : sig_vars '::' stype { LL (reverse (unLoc $1), $3) } - -stype :: { LBangType RdrName } - : ctype { unbangedType $1 } - | strict_mark atype { LL (BangType (unLoc $1) $2) } - -strict_mark :: { Located HsBang } - : '!' { L1 HsStrict } - | '{-# UNPACK' '#-}' '!' { LL HsUnbox } + : sig_vars '::' ctype { LL (reverse (unLoc $1), $3) } -- We allow the odd-looking 'inst_type' in a deriving clause, so that -- we can do deriving( forall a. C [a] ) in a newtype (GHC extension). @@ -945,8 +951,8 @@ decl :: { Located (OrdList (LHsDecl RdrName)) } return (LL $ unitOL (LL $ ValD r)) } } rhs :: { Located (GRHSs RdrName) } - : '=' exp wherebinds { L (comb3 $1 $2 $3) $ GRHSs (unguardedRHS $2) (unLoc $3) placeHolderType } - | gdrhs wherebinds { LL $ GRHSs (reverse (unLoc $1)) (unLoc $2) placeHolderType } + : '=' exp wherebinds { L (comb3 $1 $2 $3) $ GRHSs (unguardedRHS $2) (unLoc $3) } + | gdrhs wherebinds { LL $ GRHSs (reverse (unLoc $1)) (unLoc $2) } gdrhs :: { Located [LGRHS RdrName] } : gdrhs gdrh { LL ($2 : unLoc $1) } @@ -993,12 +999,12 @@ infixexp :: { LHsExpr RdrName } exp10 :: { LHsExpr RdrName } : '\\' aexp aexps opt_asig '->' exp {% checkPatterns ($2 : reverse $3) >>= \ ps -> - return (LL $ HsLam (LL $ Match ps $4 + return (LL $ HsLam (mkMatchGroup [LL $ Match ps $4 (GRHSs (unguardedRHS $6) [] - placeHolderType))) } + )])) } | 'let' binds 'in' exp { LL $ HsLet (unLoc $2) $4 } | 'if' exp 'then' exp 'else' exp { LL $ HsIf $2 $4 $6 } - | 'case' exp 'of' altslist { LL $ HsCase $2 (unLoc $4) } + | 'case' exp 'of' altslist { LL $ HsCase $2 (mkMatchGroup (unLoc $4)) } | '-' fexp { LL $ mkHsNegApp $2 } | 'do' stmtlist {% let loc = comb2 $1 $2 in @@ -1192,8 +1198,7 @@ alt :: { LMatch RdrName } return (LL (Match [p] $2 (unLoc $3))) } alt_rhs :: { Located (GRHSs RdrName) } - : ralt wherebinds { LL (GRHSs (unLoc $1) (unLoc $2) - placeHolderType) } + : ralt wherebinds { LL (GRHSs (unLoc $1) (unLoc $2)) } ralt :: { Located [LGRHS RdrName] } : '->' exp { LL (unguardedRHS $2) } @@ -1462,7 +1467,7 @@ special_sym : '!' { L1 FSLIT("!") } ----------------------------------------------------------------------------- -- Data constructors -qconid :: { Located RdrName } -- Qualified or unqualifiedb +qconid :: { Located RdrName } -- Qualified or unqualified : conid { $1 } | QCONID { L1 $ mkQual dataName (getQCONID $1) } diff --git a/ghc/compiler/parser/ParserCore.y b/ghc/compiler/parser/ParserCore.y index 757d5e3637..c777137d9a 100644 --- a/ghc/compiler/parser/ParserCore.y +++ b/ghc/compiler/parser/ParserCore.y @@ -13,7 +13,6 @@ import Module import ParserCoreUtils import LexCore import Literal -import BasicTypes import SrcLoc import TysPrim( wordPrimTyCon, intPrimTyCon, charPrimTyCon, floatPrimTyCon, doublePrimTyCon, addrPrimTyCon ) @@ -95,7 +94,7 @@ tdef :: { TyClDecl RdrName } trep :: { OccName -> [LConDecl RdrName] } : {- empty -} { (\ tc_occ -> []) } | '=' ty { (\ tc_occ -> let { dc_name = mkRdrUnqual (setOccNameSpace dataName tc_occ) ; - con_info = PrefixCon [unbangedType (toHsType $2)] } + con_info = PrefixCon [toHsType $2] } in [noLoc $ ConDecl (noLoc dc_name) [] (noLoc []) con_info]) } @@ -105,7 +104,9 @@ cons1 :: { [LConDecl RdrName] } con :: { LConDecl RdrName } : d_pat_occ attv_bndrs hs_atys - { noLoc $ ConDecl (noLoc (mkRdrUnqual $1)) $2 (noLoc []) (PrefixCon (map unbangedType $3))} + { noLoc $ ConDecl (noLoc (mkRdrUnqual $1)) $2 (noLoc []) (PrefixCon $3)} + | d_pat_occ '::' ty + { noLoc $ GadtDecl (noLoc (mkRdrUnqual $1)) (toHsType $3) } attv_bndrs :: { [LHsTyVarBndr RdrName] } : {- empty -} { [] } @@ -218,8 +219,9 @@ exp :: { IfaceExpr } : fexp { $1 } | '\\' bndrs '->' exp { foldr IfaceLam $4 $2 } | '%let' let_bind '%in' exp { IfaceLet $2 $4 } - | '%case' aexp '%of' id_bndr - '{' alts1 '}' { IfaceCase $2 (fst $4) $6 } +-- gaw 2004 + | '%case' '(' ty ')' aexp '%of' id_bndr + '{' alts1 '}' { IfaceCase $5 (fst $7) $3 $9 } | '%coerce' aty exp { IfaceNote (IfaceCoerce $2) $3 } | '%note' STRING exp { case $2 of diff --git a/ghc/compiler/parser/RdrHsSyn.lhs b/ghc/compiler/parser/RdrHsSyn.lhs index b51c2d5a9b..ae1000728a 100644 --- a/ghc/compiler/parser/RdrHsSyn.lhs +++ b/ghc/compiler/parser/RdrHsSyn.lhs @@ -107,6 +107,7 @@ extract_lty (L loc (HsTyVar tv)) acc | otherwise = acc extract_lty ty acc = extract_ty (unLoc ty) acc +extract_ty (HsBangTy _ ty) acc = extract_lty ty acc extract_ty (HsAppTy ty1 ty2) acc = extract_lty ty1 (extract_lty ty2 acc) extract_ty (HsListTy ty) acc = extract_lty ty acc extract_ty (HsPArrTy ty) acc = extract_lty ty acc @@ -131,8 +132,8 @@ extractGenericPatTyVars :: LHsBinds RdrName -> [Located RdrName] extractGenericPatTyVars binds = nubBy eqLocated (foldrBag get [] binds) where - get (L _ (FunBind _ _ ms)) acc = foldr (get_m.unLoc) acc ms - get other acc = acc + get (L _ (FunBind _ _ (MatchGroup ms _))) acc = foldr (get_m.unLoc) acc ms + get other acc = acc get_m (Match (L _ (TypePat ty) : _) _ _) acc = extract_lty ty acc get_m other acc = acc @@ -187,9 +188,11 @@ mkHsNegApp (L loc e) = f e %* * %************************************************************************ -mkBootIface, and its boring helper functions, have two purposes: +mkBootIface, and its deeply boring helper functions, have two purposes: + a) HsSyn to IfaceSyn. The parser parses the former, but we're reading an hi-boot file, and interfaces consist of the latter + b) Convert unqualifed names from the "current module" to qualified Orig names. E.g. module This where @@ -197,7 +200,10 @@ b) Convert unqualifed names from the "current module" to qualified Orig becomes This.foo :: GHC.Base.Int -> GHC.Base.Int -It assumes that everything is well kinded, of course. +It assumes that everything is well kinded, of course. Failure causes a +fatal error using pgmError, rather than a monadic error. You're supposed +to get hi-boot files right! + \begin{code} mkBootIface :: ModuleName -> [HsDecl RdrName] -> ModIface @@ -233,6 +239,14 @@ hsIfaceDecl (SigD (Sig name ty)) ifType = hsIfaceLType ty, ifIdInfo = NoInfo } +hsIfaceDecl (TyClD decl@(ClassDecl {})) + = IfaceClass { ifName = rdrNameOcc (tcdName decl), + ifTyVars = hsIfaceTvs (tcdTyVars decl), + ifCtxt = hsIfaceCtxt (unLoc (tcdCtxt decl)), + ifFDs = hsIfaceFDs (map unLoc (tcdFDs decl)), + ifSigs = [], -- Is this right?? + ifRec = NonRecursive, ifVrcs = [] } + hsIfaceDecl (TyClD decl@(TySynonym {})) = IfaceSyn { ifName = rdrNameOcc (tcdName decl), ifTyVars = hsIfaceTvs (tcdTyVars decl), @@ -241,43 +255,52 @@ hsIfaceDecl (TyClD decl@(TySynonym {})) hsIfaceDecl (TyClD decl@(TyData {})) = IfaceData { ifName = rdrNameOcc (tcdName decl), - ifTyVars = hsIfaceTvs (tcdTyVars decl), - ifCtxt = hsIfaceCtxt (unLoc (tcdCtxt decl)), - ifCons = hsIfaceCons (tcdND decl) (tcdCons decl), + ifTyVars = tvs, + ifCons = hsIfaceCons tvs decl, ifRec = NonRecursive, ifVrcs = [], ifGeneric = False } -- I'm not sure that [] is right for ifVrcs, but -- since we don't use them I'm not going to fiddle - -hsIfaceDecl (TyClD decl@(ClassDecl {})) - = IfaceClass { ifName = rdrNameOcc (tcdName decl), - ifTyVars = hsIfaceTvs (tcdTyVars decl), - ifCtxt = hsIfaceCtxt (unLoc (tcdCtxt decl)), - ifFDs = hsIfaceFDs (map unLoc (tcdFDs decl)), - ifSigs = [], -- Is this right?? - ifRec = NonRecursive, ifVrcs = [] } - -hsIfaceDecl decl = pprPanic "hsIfaceDecl" (ppr decl) - -hsIfaceCons :: NewOrData -> [LConDecl RdrName] -> IfaceConDecls -hsIfaceCons DataType [] -- data T a, meaning "constructors unspecified", - = IfAbstractTyCon -- not "no constructors" - -hsIfaceCons DataType cons -- data type - = IfDataTyCon (map (hsIfaceCon . unLoc) cons) - -hsIfaceCons NewType [con] -- newtype - = IfNewTyCon (hsIfaceCon (unLoc con)) - - -hsIfaceCon :: ConDecl RdrName -> IfaceConDecl -hsIfaceCon (ConDecl lname ex_tvs ex_ctxt details) - = IfaceConDecl (get_occ lname) is_infix - (hsIfaceTvs ex_tvs) - (hsIfaceCtxt (unLoc ex_ctxt)) - (map (hsIfaceLType . getBangType . unLoc) args) - (map (hsStrictMark . getBangStrictness . unLoc) args) - flds + where + tvs = hsIfaceTvs (tcdTyVars decl) + +hsIfaceDecl decl = pprPgmError "Illegal declaration in hi-boot file:" (ppr decl) + +hsIfaceCons :: [IfaceTvBndr] -> TyClDecl RdrName -> IfaceConDecls +hsIfaceCons tvs decl@(TyData {tcdCtxt = L _ stupid_ctxt}) + | not (null stupid_ctxt) -- Keep it simple: no data type contexts + -- Else we'll have to do "thinning"; sigh + = pprPgmError "Can't do data type contexts in hi-boot file:" (ppr decl) + +hsIfaceCons tvs (TyData {tcdND = DataType, tcdCons = []}) + = -- data T a, meaning "constructors unspecified", + IfAbstractTyCon -- not "no constructors" + +hsIfaceCons tvs (TyData {tcdND = DataType, tcdCons = cons}) + = IfDataTyCon Nothing (map (hsIfaceCon tvs . unLoc) cons) + +hsIfaceCons tvs (TyData {tcdND = NewType, tcdCons = [con]}) + = IfNewTyCon (hsIfaceCon tvs (unLoc con)) + +hsIfaceCons tvs decl = pprPgmError "Illegal declaration in hi-boot file:" (ppr decl) + + +hsIfaceCon :: [IfaceTvBndr] -> ConDecl RdrName -> IfaceConDecl +hsIfaceCon tvs (ConDecl lname ex_tvs ex_ctxt details) + | null ex_tvs && null (unLoc ex_ctxt) + = IfVanillaCon { ifConOcc = get_occ lname, + ifConInfix = is_infix, + ifConArgTys = map hsIfaceLType args, + ifConStricts = map (hsStrictMark . getBangStrictness) args, + ifConFields = flds } + | null flds + = IfGadtCon { ifConOcc = get_occ lname, + ifConTyVars = tvs ++ hsIfaceTvs ex_tvs, + ifConCtxt = hsIfaceCtxt (unLoc ex_ctxt), + ifConArgTys = map hsIfaceLType args, + ifConResTys = map (IfaceTyVar . fst) tvs, + ifConStricts = map (hsStrictMark . getBangStrictness) args } + | otherwise = pprPgmError "Fields illegal in existential" (ppr (unLoc lname)) where (is_infix, args, flds) = case details of PrefixCon args -> (False, args, []) @@ -285,6 +308,9 @@ hsIfaceCon (ConDecl lname ex_tvs ex_ctxt details) RecCon fs -> (False, map snd fs, map (get_occ . fst) fs) get_occ lname = rdrNameOcc (unLoc lname) +hsIfaceCon _tvs (GadtDecl lname con_ty) -- Not yet + = pprPgmError "Can't use GADTs in hi-boot files (yet)" (ppr (unLoc lname)) + hsStrictMark :: HsBang -> StrictnessMark -- Warning: in source files the {-# UNPACK #-} pragma (HsUnbox) is a request -- but in an hi-boot file it's interpreted as the Truth! @@ -318,10 +344,11 @@ hsIfaceType (HsPArrTy t) = IfaceTyConApp IfacePArrTc [hsIfaceLType t] hsIfaceType (HsTupleTy bx ts) = IfaceTyConApp (IfaceTupTc bx (length ts)) (hsIfaceLTypes ts) hsIfaceType (HsOpTy t1 tc t2) = hs_tc_app (HsTyVar (unLoc tc)) (hsIfaceLTypes [t1, t2]) hsIfaceType (HsParTy t) = hsIfaceLType t +hsIfaceType (HsBangTy _ t) = hsIfaceLType t hsIfaceType (HsPredTy p) = IfacePredTy (hsIfacePred p) hsIfaceType (HsKindSig t _) = hsIfaceLType t -hsIfaceType (HsNumTy n) = panic "hsIfaceType:HsNum" -hsIfaceType (HsSpliceTy _) = panic "hsIfaceType:HsSpliceTy" +hsIfaceType ty = pprPanic "hsIfaceType" (ppr ty) + -- HsNumTy, HsSpliceTy ----------- hsIfaceLTypes tys = map (hsIfaceType.unLoc) tys @@ -347,6 +374,7 @@ hs_tc_app (HsTyVar n) args hs_tc_app ty args = foldl IfaceAppTy (hsIfaceType ty) args ----------- +hsIfaceTvs :: [LHsTyVarBndr RdrName] -> [IfaceTvBndr] hsIfaceTvs tvs = map (hsIfaceTv.unLoc) tvs ----------- @@ -414,15 +442,16 @@ getMonoBind :: LHsBind RdrName -> [LHsDecl RdrName] -- -- No AndMonoBinds or EmptyMonoBinds here; just single equations -getMonoBind (L loc (FunBind lf@(L _ f) inf mtchs)) binds +-- gaw 2004 +getMonoBind (L loc (FunBind lf@(L _ f) inf (MatchGroup mtchs _))) binds | has_args mtchs = go mtchs loc binds where - go mtchs1 loc1 (L loc2 (ValD (FunBind f2 inf2 mtchs2)) : binds) + go mtchs1 loc1 (L loc2 (ValD (FunBind f2 inf2 (MatchGroup mtchs2 _))) : binds) | f == unLoc f2 = go (mtchs2++mtchs1) loc binds where loc = combineSrcSpans loc1 loc2 go mtchs1 loc binds - = (L loc (FunBind lf inf (reverse mtchs1)), binds) + = (L loc (FunBind lf inf (mkMatchGroup (reverse mtchs1))), binds) -- reverse the final matches, to get it back in the right order getMonoBind bind binds = (bind, binds) @@ -520,7 +549,7 @@ mkPrefixCon :: LHsType RdrName -> [LBangType RdrName] mkPrefixCon ty tys = split ty tys where - split (L _ (HsAppTy t u)) ts = split t (unbangedType u : ts) + split (L _ (HsAppTy t u)) ts = split t (u : ts) split (L l (HsTyVar tc)) ts = do data_con <- tyConToDataCon l tc return (data_con, PrefixCon ts) split (L l _) _ = parseError l "parse error in data/newtype declaration" @@ -772,13 +801,12 @@ checkValDef lhs opt_sig (L rhs_span grhss) showRdrName (unLoc f)) else do ps <- checkPatterns es let match_span = combineSrcSpans (getLoc lhs) rhs_span - return (FunBind f inf [L match_span (Match ps opt_sig grhss)]) - -- the span of the match covers the entire equation. That isn't - -- quite right, but it'll do for now. + return (FunBind f inf (mkMatchGroup [L match_span (Match ps opt_sig grhss)])) + -- The span of the match covers the entire equation. + -- That isn't quite right, but it'll do for now. | otherwise = do lhs <- checkPattern lhs - return (PatBind lhs grhss) - + return (PatBind lhs grhss placeHolderType) checkValSig :: LHsExpr RdrName diff --git a/ghc/compiler/prelude/PrelRules.lhs b/ghc/compiler/prelude/PrelRules.lhs index 8f5df8c60e..5cbcdb314f 100644 --- a/ghc/compiler/prelude/PrelRules.lhs +++ b/ghc/compiler/prelude/PrelRules.lhs @@ -31,7 +31,8 @@ import Literal ( Literal(..), mkMachInt, mkMachWord , float2DoubleLit, double2FloatLit ) import PrimOp ( PrimOp(..), primOpOcc ) -import TysWiredIn ( trueDataConId, falseDataConId ) +-- gaw 2004 +import TysWiredIn ( boolTy, trueDataConId, falseDataConId ) import TyCon ( tyConDataCons_maybe, isEnumerationTyCon, isNewTyCon ) import DataCon ( dataConTag, dataConTyCon, dataConWorkId, fIRST_TAG ) import CoreUtils ( cheapEqExpr, exprIsConApp_maybe ) @@ -288,7 +289,8 @@ litEq is_eq [expr, Lit lit] = do_lit_eq is_eq lit expr litEq is_eq other = Nothing do_lit_eq is_eq lit expr - = Just (Case expr (mkWildId (literalType lit)) +-- gaw 2004 + = Just (Case expr (mkWildId (literalType lit)) boolTy [(DEFAULT, [], val_if_neq), (LitAlt lit, [], val_if_eq)]) where diff --git a/ghc/compiler/prelude/TysWiredIn.lhs b/ghc/compiler/prelude/TysWiredIn.lhs index eb8124f8f5..7f78ecd449 100644 --- a/ghc/compiler/prelude/TysWiredIn.lhs +++ b/ghc/compiler/prelude/TysWiredIn.lhs @@ -69,11 +69,9 @@ import TyCon ( TyCon, AlgTyConRhs(DataTyCon), tyConDataCons, mkTupleTyCon, mkAlgTyCon, tyConName ) -import BasicTypes ( Arity, RecFlag(..), Boxity(..), isBoxed, StrictnessMark(..), - Fixity(..), FixityDirection(..), defaultFixity ) +import BasicTypes ( Arity, RecFlag(..), Boxity(..), isBoxed, StrictnessMark(..) ) -import Type ( Type, mkTyConTy, mkTyConApp, mkTyVarTy, mkTyVarTys, - ThetaType, TyThing(..) ) +import Type ( Type, mkTyConTy, mkTyConApp, mkTyVarTy, mkTyVarTys, TyThing(..) ) import Kind ( mkArrowKinds, liftedTypeKind, ubxTupleKind ) import Unique ( incrUnique, mkTupleTyConUnique, mkTupleDataConUnique, mkPArrDataConUnique ) @@ -177,10 +175,9 @@ pcTyCon is_enum is_rec name tyvars argvrcs cons tycon = mkAlgTyCon name (mkArrowKinds (map tyVarKind tyvars) liftedTypeKind) tyvars - [] -- No context argvrcs - (DataTyCon cons is_enum) - [] -- No record selectors + (DataTyCon (Just []) cons is_enum) + [] -- No record selectors is_rec True -- All the wired-in tycons have generics @@ -198,11 +195,12 @@ pcDataConWithFixity :: Bool -> Name -> [TyVar] -> [Type] -> TyCon -> DataCon pcDataConWithFixity declared_infix dc_name tyvars arg_tys tycon = data_con where - data_con = mkDataCon dc_name declared_infix + data_con = mkDataCon dc_name declared_infix True {- Vanilla -} (map (const NotMarkedStrict) arg_tys) [{- No labelled fields -}] - tyvars [] [] [] arg_tys tycon + tyvars [] [] arg_tys tycon (mkTyVarTys tyvars) (mkDataConIds bogus_wrap_name wrk_name data_con) + mod = nameModule dc_name wrk_occ = mkDataConWorkerOcc (nameOccName dc_name) diff --git a/ghc/compiler/rename/RnBinds.lhs b/ghc/compiler/rename/RnBinds.lhs index 843f28e41c..57201211d9 100644 --- a/ghc/compiler/rename/RnBinds.lhs +++ b/ghc/compiler/rename/RnBinds.lhs @@ -23,7 +23,7 @@ import RdrHsSyn import RnHsSyn import TcRnMonad import RnTypes ( rnHsSigType, rnLHsType, rnLPat ) -import RnExpr ( rnMatch, rnGRHSs, checkPrecMatch ) +import RnExpr ( rnMatchGroup, rnMatch, rnGRHSs, checkPrecMatch ) import RnEnv ( bindLocatedLocalsRn, lookupLocatedBndrRn, lookupLocatedInstDeclBndr, lookupLocatedSigOccRn, bindPatSigTyVars, bindPatSigTyVarsFV, @@ -41,10 +41,7 @@ import List ( unzip4 ) import SrcLoc ( mkSrcSpan, Located(..), unLoc ) import Bag import Outputable - import Monad ( foldM ) - -import SrcLoc (getLoc) -- tmp \end{code} -- ToDo: Put the annotations into the monad, so that they arrive in the proper @@ -157,7 +154,7 @@ it expects the global environment to contain bindings for the binders contains bindings for the binders of this particular binding. \begin{code} -rnTopBinds :: Bag (LHsBind RdrName) +rnTopBinds :: LHsBinds RdrName -> [LSig RdrName] -> RnM ([HsBindGroup Name], DefUses) @@ -239,7 +236,7 @@ This is done {\em either} by pass 3 (for the top-level bindings), \begin{code} rnBinds :: TopLevelFlag - -> Bag (LHsBind RdrName) + -> LHsBinds RdrName -> [LSig RdrName] -> RnM ([HsBindGroup Name], DefUses) @@ -287,13 +284,13 @@ unique ``vertex tags'' on its output; minor plumbing required. \begin{code} mkBindVertices :: [LSig Name] -- Signatures - -> Bag (LHsBind RdrName) + -> LHsBinds RdrName -> RnM [BindVertex] mkBindVertices sigs = mapM (mkBindVertex sigs) . bagToList mkBindVertex :: [LSig Name] -> LHsBind RdrName -> RnM BindVertex -mkBindVertex sigs (L loc (PatBind pat grhss)) - = addSrcSpan loc $ +mkBindVertex sigs (L loc (PatBind pat grhss ty)) + = setSrcSpan loc $ rnLPat pat `thenM` \ (pat', pat_fvs) -> -- Find which things are bound in this group @@ -304,19 +301,19 @@ mkBindVertex sigs (L loc (PatBind pat grhss)) rnGRHSs PatBindRhs grhss `thenM` \ (grhss', fvs) -> returnM (names_bound_here, fvs `plusFV` pat_fvs, - L loc (PatBind pat' grhss'), sigs_for_me + L loc (PatBind pat' grhss' ty), sigs_for_me ) mkBindVertex sigs (L loc (FunBind name inf matches)) - = addSrcSpan loc $ + = setSrcSpan loc $ lookupLocatedBndrRn name `thenM` \ new_name -> let plain_name = unLoc new_name names_bound_here = unitNameSet plain_name in sigsForMe names_bound_here sigs `thenM` \ sigs_for_me -> - mapFvRn (rnMatch (FunRhs plain_name)) matches `thenM` \ (new_matches, fvs) -> - mappM_ (checkPrecMatch inf plain_name) new_matches `thenM_` + rnMatchGroup (FunRhs plain_name) matches `thenM` \ (new_matches, fvs) -> + checkPrecMatch inf plain_name new_matches `thenM_` returnM (unitNameSet plain_name, fvs, L loc (FunBind new_name inf new_matches), sigs_for_me @@ -354,7 +351,7 @@ a binder. \begin{code} rnMethodBinds :: Name -- Class name -> [Name] -- Names for generic type variables - -> (LHsBinds RdrName) + -> LHsBinds RdrName -> RnM (LHsBinds Name, FreeVars) rnMethodBinds cls gen_tyvars binds @@ -363,19 +360,21 @@ rnMethodBinds cls gen_tyvars binds (bind', fvs_bind) <- rnMethodBind cls gen_tyvars bind return (bind' `unionBags` binds, fvs_bind `plusFV` fvs) - -rnMethodBind cls gen_tyvars (L loc (FunBind name inf matches)) - = addSrcSpan loc $ +rnMethodBind cls gen_tyvars (L loc (FunBind name inf (MatchGroup matches _))) + = setSrcSpan loc $ lookupLocatedInstDeclBndr cls name `thenM` \ sel_name -> let plain_name = unLoc sel_name in -- We use the selector name as the binder mapFvRn (rn_match plain_name) matches `thenM` \ (new_matches, fvs) -> - mappM_ (checkPrecMatch inf plain_name) new_matches `thenM_` - returnM (unitBag (L loc (FunBind sel_name inf new_matches)), fvs `addOneFV` plain_name) + let + new_group = MatchGroup new_matches placeHolderType + in + checkPrecMatch inf plain_name new_group `thenM_` + returnM (unitBag (L loc (FunBind sel_name inf new_group)), fvs `addOneFV` plain_name) where - -- Gruesome; bring into scope the correct members of the generic type variables - -- See comments in RnSource.rnSourceDecl(ClassDecl) + -- Truly gruesome; bring into scope the correct members of the generic + -- type variables. See comments in RnSource.rnSourceDecl(ClassDecl) rn_match sel_name match@(L _ (Match (L _ (TypePat ty) : _) _ _)) = extendTyVarEnvFVRn gen_tvs $ rnMatch (FunRhs sel_name) match @@ -387,7 +386,7 @@ rnMethodBind cls gen_tyvars (L loc (FunBind name inf matches)) -- Can't handle method pattern-bindings which bind multiple methods. -rnMethodBind cls gen_tyvars mbind@(L loc (PatBind other_pat _)) +rnMethodBind cls gen_tyvars mbind@(L loc (PatBind other_pat _ _)) = addLocErr mbind methodBindErr `thenM_` returnM (emptyBag, emptyFVs) \end{code} diff --git a/ghc/compiler/rename/RnEnv.lhs b/ghc/compiler/rename/RnEnv.lhs index c9e48cbfca..821f6a97a4 100644 --- a/ghc/compiler/rename/RnEnv.lhs +++ b/ghc/compiler/rename/RnEnv.lhs @@ -42,14 +42,13 @@ import RdrName ( RdrName, rdrNameModule, rdrNameOcc, isQual, isUnqual, isOrig, isLocalGRE, extendLocalRdrEnv, elemLocalRdrEnv, lookupLocalRdrEnv, Provenance(..), pprNameProvenance, ImportSpec(..) ) -import HsTypes ( hsTyVarName, replaceTyVarName ) +import HsTypes ( replaceTyVarName ) import HscTypes ( availNames, ModIface(..), FixItem(..), lookupFixity ) import TcRnMonad import Name ( Name, nameIsLocalOrFrom, mkInternalName, isInternalName, nameSrcLoc, nameOccName, nameModuleName, nameParent ) import NameSet -import OccName ( tcName, isDataOcc, occNameFlavour, reportIfUnused, - isVarOcc ) +import OccName ( tcName, isDataOcc, occNameFlavour, reportIfUnused ) import Module ( Module, ModuleName, moduleName, mkHomeModule ) import PrelNames ( mkUnboundName, rOOT_MAIN_Name, iNTERACTIVE, consDataConKey, hasKey ) import UniqSupply @@ -130,7 +129,7 @@ lookupLocatedBndrRn :: Located RdrName -> RnM (Located Name) lookupLocatedBndrRn = wrapLocM lookupBndrRn lookupBndrRn :: RdrName -> RnM Name --- NOTE: assumes that the SrcSpan of the binder has already been addSrcSpan'd +-- NOTE: assumes that the SrcSpan of the binder has already been setSrcSpan'd lookupBndrRn rdr_name = getLocalRdrEnv `thenM` \ local_env -> case lookupLocalRdrEnv local_env rdr_name of @@ -590,7 +589,7 @@ bindTyVarsRn :: SDoc -> [LHsTyVarBndr RdrName] -> RnM a bindTyVarsRn doc_str tyvar_names enclosed_scope = let - located_tyvars = [L loc (hsTyVarName tv) | L loc tv <- tyvar_names] + located_tyvars = hsLTyVarLocNames tyvar_names in bindLocatedLocalsRn doc_str located_tyvars $ \ names -> enclosed_scope (zipWith replace tyvar_names names) @@ -641,7 +640,7 @@ checkShadowing doc_str loc_rdr_names check_shadow (L loc rdr_name) | rdr_name `elemLocalRdrEnv` local_env || not (null (lookupGRE_RdrName rdr_name global_env )) - = addSrcSpan loc $ addWarn (shadowedNameWarn doc_str rdr_name) + = setSrcSpan loc $ addWarn (shadowedNameWarn doc_str rdr_name) | otherwise = returnM () in mappM_ check_shadow loc_rdr_names @@ -675,7 +674,7 @@ warnUnusedModules :: [(ModuleName,SrcSpan)] -> RnM () warnUnusedModules mods = ifOptM Opt_WarnUnusedImports (mappM_ bleat mods) where - bleat (mod,loc) = addSrcSpan loc $ addWarn (mk_warn mod) + bleat (mod,loc) = setSrcSpan loc $ addWarn (mk_warn mod) mk_warn m = vcat [ptext SLIT("Module") <+> quotes (ppr m) <+> text "is imported, but nothing from it is used", parens (ptext SLIT("except perhaps instances visible in") <+> @@ -749,7 +748,7 @@ badOrigBinding name -- The rdrNameOcc is because we don't want to print Prelude.(,) dupNamesErr descriptor (L loc name : dup_things) - = addSrcSpan loc $ + = setSrcSpan loc $ addErr ((ptext SLIT("Conflicting definitions for") <+> quotes (ppr name)) $$ descriptor) diff --git a/ghc/compiler/rename/RnExpr.lhs b/ghc/compiler/rename/RnExpr.lhs index 1b2700497b..9329f6a234 100644 --- a/ghc/compiler/rename/RnExpr.lhs +++ b/ghc/compiler/rename/RnExpr.lhs @@ -11,7 +11,7 @@ free variables. \begin{code} module RnExpr ( - rnMatch, rnGRHSs, rnLExpr, rnExpr, rnStmts, + rnMatchGroup, rnMatch, rnGRHSs, rnLExpr, rnExpr, rnStmts, checkPrecMatch, checkTH ) where @@ -60,6 +60,11 @@ import List ( unzip4 ) ************************************************************************ \begin{code} +rnMatchGroup :: HsMatchContext Name -> MatchGroup RdrName -> RnM (MatchGroup Name, FreeVars) +rnMatchGroup ctxt (MatchGroup ms _) + = mapFvRn (rnMatch ctxt) ms `thenM` \ (new_ms, ms_fvs) -> + returnM (MatchGroup new_ms placeHolderType, ms_fvs) + rnMatch :: HsMatchContext Name -> LMatch RdrName -> RnM (LMatch Name, FreeVars) rnMatch ctxt = wrapLocFstM (rnMatch' ctxt) @@ -99,10 +104,11 @@ rnMatch' ctxt match@(Match pats maybe_rhs_sig grhss) \begin{code} rnGRHSs :: HsMatchContext Name -> GRHSs RdrName -> RnM (GRHSs Name, FreeVars) -rnGRHSs ctxt (GRHSs grhss binds _) +-- gaw 2004 +rnGRHSs ctxt (GRHSs grhss binds) = rnBindGroupsAndThen binds $ \ binds' -> mapFvRn (rnGRHS ctxt) grhss `thenM` \ (grhss', fvGRHSs) -> - returnM (GRHSs grhss' binds' placeHolderType, fvGRHSs) + returnM (GRHSs grhss' binds', fvGRHSs) rnGRHS :: HsMatchContext Name -> LGRHS RdrName -> RnM (LGRHS Name, FreeVars) rnGRHS ctxt = wrapLocFstM (rnGRHS' ctxt) @@ -184,10 +190,6 @@ rnExpr (HsOverLit lit) = rnOverLit lit `thenM` \ (lit', fvs) -> returnM (HsOverLit lit', fvs) -rnExpr (HsLam match) - = rnMatch LambdaExpr match `thenM` \ (match', fvMatch) -> - returnM (HsLam match', fvMatch) - rnExpr (HsApp fun arg) = rnLExpr fun `thenM` \ (fun',fvFun) -> rnLExpr arg `thenM` \ (arg',fvArg) -> @@ -251,10 +253,14 @@ rnExpr (HsSCC lbl expr) = rnLExpr expr `thenM` \ (expr', fvs_expr) -> returnM (HsSCC lbl expr', fvs_expr) -rnExpr (HsCase expr ms) +rnExpr (HsLam matches) + = rnMatchGroup LambdaExpr matches `thenM` \ (matches', fvMatch) -> + returnM (HsLam matches', fvMatch) + +rnExpr (HsCase expr matches) = rnLExpr expr `thenM` \ (new_expr, e_fvs) -> - mapFvRn (rnMatch CaseAlt) ms `thenM` \ (new_ms, ms_fvs) -> - returnM (HsCase new_expr new_ms, e_fvs `plusFV` ms_fvs) + rnMatchGroup CaseAlt matches `thenM` \ (new_matches, ms_fvs) -> + returnM (HsCase new_expr new_matches, e_fvs `plusFV` ms_fvs) rnExpr (HsLet binds expr) = rnBindGroupsAndThen binds $ \ binds' -> @@ -455,9 +461,7 @@ convertOpFormsLCmd = fmap convertOpFormsCmd convertOpFormsCmd :: HsCmd id -> HsCmd id convertOpFormsCmd (HsApp c e) = HsApp (convertOpFormsLCmd c) e - convertOpFormsCmd (HsLam match) = HsLam (convertOpFormsMatch match) - convertOpFormsCmd (OpApp c1 op fixity c2) = let arg1 = L (getLoc c1) $ HsCmdTop (convertOpFormsLCmd c1) [] placeHolderType [] @@ -467,8 +471,9 @@ convertOpFormsCmd (OpApp c1 op fixity c2) convertOpFormsCmd (HsPar c) = HsPar (convertOpFormsLCmd c) +-- gaw 2004 convertOpFormsCmd (HsCase exp matches) - = HsCase exp (map convertOpFormsMatch matches) + = HsCase exp (convertOpFormsMatch matches) convertOpFormsCmd (HsIf exp c1 c2) = HsIf exp (convertOpFormsLCmd c1) (convertOpFormsLCmd c2) @@ -494,12 +499,13 @@ convertOpFormsStmt (RecStmt stmts lvs rvs es) = RecStmt (map (fmap convertOpFormsStmt) stmts) lvs rvs es convertOpFormsStmt stmt = stmt -convertOpFormsMatch = fmap convert +convertOpFormsMatch (MatchGroup ms ty) + = MatchGroup (map (fmap convert) ms) ty where convert (Match pat mty grhss) = Match pat mty (convertOpFormsGRHSs grhss) -convertOpFormsGRHSs (GRHSs grhss binds ty) - = GRHSs (map convertOpFormsGRHS grhss) binds ty +convertOpFormsGRHSs (GRHSs grhss binds) + = GRHSs (map convertOpFormsGRHS grhss) binds convertOpFormsGRHS = fmap convert where convert (GRHS stmts) @@ -538,7 +544,7 @@ methodNamesCmd (HsApp c e) = methodNamesLCmd c methodNamesCmd (HsLam match) = methodNamesMatch match methodNamesCmd (HsCase scrut matches) - = plusFVs (map methodNamesMatch matches) `addOneFV` choiceAName + = methodNamesMatch matches `addOneFV` choiceAName methodNamesCmd other = emptyFVs -- Other forms can't occur in commands, but it's not convenient @@ -546,10 +552,14 @@ methodNamesCmd other = emptyFVs -- The type checker will complain later --------------------------------------------------- -methodNamesMatch (L _ (Match pats sig_ty grhss)) = methodNamesGRHSs grhss +methodNamesMatch (MatchGroup ms ty) + = plusFVs (map do_one ms) + where + do_one (L _ (Match pats sig_ty grhss)) = methodNamesGRHSs grhss ------------------------------------------------- -methodNamesGRHSs (GRHSs grhss binds ty) = plusFVs (map methodNamesGRHS grhss) +-- gaw 2004 +methodNamesGRHSs (GRHSs grhss binds) = plusFVs (map methodNamesGRHS grhss) ------------------------------------------------- methodNamesGRHS (L _ (GRHS stmts)) = methodNamesLStmt (last stmts) @@ -1055,18 +1065,20 @@ not_op_app other = True \end{code} \begin{code} -checkPrecMatch :: Bool -> Name -> LMatch Name -> RnM () +checkPrecMatch :: Bool -> Name -> MatchGroup Name -> RnM () + -- True indicates an infix lhs + -- See comments with rnExpr (OpApp ...) about "deriving" -checkPrecMatch False fn match +checkPrecMatch False fn match = returnM () +checkPrecMatch True op (MatchGroup ms _) + = mapM_ check ms + where + check (L _ (Match (p1:p2:_) _ _)) + = checkPrec op (unLoc p1) False `thenM_` + checkPrec op (unLoc p2) True -checkPrecMatch True op (L _ (Match (p1:p2:_) _ _)) - -- True indicates an infix lhs - = -- See comments with rnExpr (OpApp ...) about "deriving" - checkPrec op (unLoc p1) False `thenM_` - checkPrec op (unLoc p2) True - -checkPrecMatch True op _ = panic "checkPrecMatch" + check _ = panic "checkPrecMatch" checkPrec op (ConPatIn op1 (InfixCon _ _)) right = lookupFixityRn op `thenM` \ op_fix@(Fixity op_prec op_dir) -> diff --git a/ghc/compiler/rename/RnHsSyn.lhs b/ghc/compiler/rename/RnHsSyn.lhs index bc2fa4dc5a..9ff40d5f22 100644 --- a/ghc/compiler/rename/RnHsSyn.lhs +++ b/ghc/compiler/rename/RnHsSyn.lhs @@ -14,6 +14,7 @@ import TysWiredIn ( tupleTyCon, listTyCon, parrTyCon, charTyCon ) import Name ( Name, getName, isTyVarName ) import NameSet import BasicTypes ( Boxity ) +-- gaw 2004 import SrcLoc ( Located(..), unLoc ) \end{code} @@ -54,6 +55,7 @@ extractHsTyNames ty get (HsPredTy p) = extractHsPredTyNames p get (HsOpTy ty1 op ty2) = getl ty1 `unionNameSets` getl ty2 `unionNameSets` unitNameSet (unLoc op) get (HsParTy ty) = getl ty + get (HsBangTy _ ty) = getl ty get (HsNumTy n) = emptyNameSet get (HsTyVar tv) = unitNameSet tv get (HsSpliceTy _) = emptyNameSet -- Type splices mention no type variables @@ -110,12 +112,15 @@ conDeclFVs (L _ (ConDecl _ tyvars context details)) = delFVs (map hsLTyVarName tyvars) $ extractHsCtxtTyNames context `plusFV` conDetailsFVs details +-- gaw 2004 +conDeclFVs (L _ (GadtDecl _ ty)) + = extractHsTyNames ty -conDetailsFVs (PrefixCon btys) = plusFVs (map bangTyFVs btys) +conDetailsFVs (PrefixCon btys) = plusFVs (map bangTyFVs btys) conDetailsFVs (InfixCon bty1 bty2) = bangTyFVs bty1 `plusFV` bangTyFVs bty2 conDetailsFVs (RecCon flds) = plusFVs [bangTyFVs bty | (_, bty) <- flds] -bangTyFVs bty = extractHsTyNames (getBangType (unLoc bty)) +bangTyFVs bty = extractHsTyNames (getBangType bty) \end{code} diff --git a/ghc/compiler/rename/RnNames.lhs b/ghc/compiler/rename/RnNames.lhs index 396aba968e..6e8c6be8a6 100644 --- a/ghc/compiler/rename/RnNames.lhs +++ b/ghc/compiler/rename/RnNames.lhs @@ -33,7 +33,6 @@ import Name ( Name, nameSrcLoc, nameOccName, nameModuleName, isWiredInName, nameParent, nameParent_maybe, isExternalName, nameModule, isBuiltInSyntax ) import NameSet -import NameEnv import OccName ( srcDataName, isTcOcc, occNameFlavour, OccEnv, mkOccEnv, lookupOccEnv, emptyOccEnv, extendOccEnv ) import HscTypes ( GenAvailInfo(..), AvailInfo, Avails, GhciMode(..), @@ -49,7 +48,7 @@ import RdrName ( RdrName, rdrNameOcc, setRdrNameSpace, Provenance(..), ImportSpec(..), isLocalGRE, pprNameProvenance ) import Outputable -import Maybes ( isJust, isNothing, catMaybes, mapCatMaybes, seqMaybe ) +import Maybes ( isNothing, catMaybes, mapCatMaybes, seqMaybe ) import SrcLoc ( noSrcLoc, Located(..), mkGeneralSrcSpan, unLoc, noLoc, srcLocSpan, SrcSpan ) import BasicTypes ( DeprecTxt ) @@ -133,7 +132,7 @@ importsFromImportDecl :: Module importsFromImportDecl this_mod (L loc (ImportDecl loc_imp_mod_name want_boot qual_only as_mod imp_details)) = - addSrcSpan loc $ + setSrcSpan loc $ -- If there's an error in loadInterface, (e.g. interface -- file not found) we get lots of spurious errors from 'filterImports' @@ -738,7 +737,7 @@ reportDeprecations tcg_env check hpt pit (GRE {gre_name = name, gre_prov = Imported (imp_spec:_) _}) | name `elemNameSet` used_names , Just deprec_txt <- lookupDeprec hpt pit name - = addSrcSpan (is_loc imp_spec) $ + = setSrcSpan (is_loc imp_spec) $ addWarn (sep [ptext SLIT("Deprecated use of") <+> occNameFlavour (nameOccName name) <+> quotes (ppr name), diff --git a/ghc/compiler/rename/RnSource.lhs b/ghc/compiler/rename/RnSource.lhs index e173907173..7d3d308d3e 100644 --- a/ghc/compiler/rename/RnSource.lhs +++ b/ghc/compiler/rename/RnSource.lhs @@ -39,7 +39,7 @@ import Name ( Name ) import NameSet import NameEnv import Outputable -import SrcLoc ( Located(..), unLoc, getLoc ) +import SrcLoc ( Located(..), unLoc, getLoc, noLoc ) import CmdLineOpts ( DynFlag(..) ) -- Warn of unused for-all'd tyvars import Maybes ( seqMaybe ) @@ -155,7 +155,7 @@ rnSrcFixityDecls fix_decls rnFixityDecl :: FixityEnv -> LFixitySig RdrName -> RnM FixityEnv rnFixityDecl fix_env (L loc (FixitySig rdr_name fixity)) - = addSrcSpan loc $ + = setSrcSpan loc $ -- GHC extension: look up both the tycon and data con -- for con-like things -- If neither are in scope, report an error; otherwise @@ -486,24 +486,50 @@ rnTyClDecl (ForeignType {tcdLName = name, tcdFoType = fo_type, tcdExtName = ext_ emptyFVs) rnTyClDecl (TyData {tcdND = new_or_data, tcdCtxt = context, tcdLName = tycon, - tcdTyVars = tyvars, tcdCons = condecls, - tcdDerivs = derivs}) - = lookupLocatedTopBndrRn tycon `thenM` \ tycon' -> - bindTyVarsRn data_doc tyvars $ \ tyvars' -> - rnContext data_doc context `thenM` \ context' -> - rn_derivs derivs `thenM` \ (derivs', deriv_fvs) -> - checkDupNames data_doc con_names `thenM_` - rnConDecls (unLoc tycon') condecls `thenM` \ condecls' -> - returnM (TyData {tcdND = new_or_data, tcdCtxt = context', tcdLName = tycon', - tcdTyVars = tyvars', tcdCons = condecls', - tcdDerivs = derivs'}, - delFVs (map hsLTyVarName tyvars') $ - extractHsCtxtTyNames context' `plusFV` - plusFVs (map conDeclFVs condecls') `plusFV` - deriv_fvs) + tcdTyVars = tyvars, tcdCons = condecls, + tcdDerivs = derivs}) + | is_vanilla -- Normal Haskell data type decl + = bindTyVarsRn data_doc tyvars $ \ tyvars' -> + do { tycon' <- lookupLocatedTopBndrRn tycon + ; context' <- rnContext data_doc context + ; (derivs', deriv_fvs) <- rn_derivs derivs + ; checkDupNames data_doc con_names + ; condecls' <- rnConDecls (unLoc tycon') condecls + ; returnM (TyData {tcdND = new_or_data, tcdCtxt = context', tcdLName = tycon', + tcdTyVars = tyvars', tcdCons = condecls', + tcdDerivs = derivs'}, + delFVs (map hsLTyVarName tyvars') $ + extractHsCtxtTyNames context' `plusFV` + plusFVs (map conDeclFVs condecls') `plusFV` + deriv_fvs) } + + | otherwise -- GADT + = ASSERT( null (unLoc context) ) + do { tycon' <- lookupLocatedTopBndrRn tycon + ; tyvars' <- bindTyVarsRn data_doc tyvars + (\ tyvars' -> return tyvars') + -- For GADTs, the type variables in the declaration + -- do not scope over the constructor signatures + -- data T a where { T1 :: forall b. b-> b } + ; (derivs', deriv_fvs) <- rn_derivs derivs + ; checkDupNames data_doc con_names + ; condecls' <- rnConDecls (unLoc tycon') condecls + ; returnM (TyData {tcdND = new_or_data, tcdCtxt = noLoc [], tcdLName = tycon', + tcdTyVars = tyvars', tcdCons = condecls', + tcdDerivs = derivs'}, + plusFVs (map conDeclFVs condecls') `plusFV` deriv_fvs) } + where + is_vanilla = case condecls of -- Yuk + [] -> True + L _ (ConDecl {}) : _ -> True + other -> False + data_doc = text "In the data type declaration for" <+> quotes (ppr tycon) - con_names = [ n | L _ (ConDecl n _ _ _) <- condecls ] + con_names = map con_names_helper condecls + + con_names_helper (L _ (ConDecl n _ _ _)) = n + con_names_helper (L _ (GadtDecl n _)) = n rn_derivs Nothing = returnM (Nothing, emptyFVs) rn_derivs (Just ds) = rnLHsTypes data_doc ds `thenM` \ ds' -> @@ -608,13 +634,21 @@ rnConDecl (ConDecl name tvs cxt details) where doc = text "In the definition of data constructor" <+> quotes (ppr name) +rnConDecl (GadtDecl name ty) + = addLocM checkConName name `thenM_` + lookupLocatedTopBndrRn name `thenM` \ new_name -> + rnHsSigType doc ty `thenM` \ new_ty -> + returnM (GadtDecl new_name new_ty) + where + doc = text "In the definition of data constructor" <+> quotes (ppr name) + rnConDetails doc (PrefixCon tys) - = mappM (rnLBangTy doc) tys `thenM` \ new_tys -> + = mappM (rnLHsType doc) tys `thenM` \ new_tys -> returnM (PrefixCon new_tys) rnConDetails doc (InfixCon ty1 ty2) - = rnLBangTy doc ty1 `thenM` \ new_ty1 -> - rnLBangTy doc ty2 `thenM` \ new_ty2 -> + = rnLHsType doc ty1 `thenM` \ new_ty1 -> + rnLHsType doc ty2 `thenM` \ new_ty2 -> returnM (InfixCon new_ty1 new_ty2) rnConDetails doc (RecCon fields) @@ -626,15 +660,9 @@ rnConDetails doc (RecCon fields) rnField doc (name, ty) = lookupLocatedTopBndrRn name `thenM` \ new_name -> - rnLBangTy doc ty `thenM` \ new_ty -> + rnLHsType doc ty `thenM` \ new_ty -> returnM (new_name, new_ty) -rnLBangTy doc = wrapLocM (rnBangTy doc) - -rnBangTy doc (BangType s ty) - = rnLHsType doc ty `thenM` \ new_ty -> - returnM (BangType s new_ty) - -- This data decl will parse OK -- data T = a Int -- treating "a" as the constructor. @@ -692,4 +720,4 @@ rnSplice (HsSplice n expr) newLocalsRn [L loc n] `thenM` \ [n'] -> rnLExpr expr `thenM` \ (expr', fvs) -> returnM (HsSplice n' expr', fvs) -\end{code}
\ No newline at end of file +\end{code} diff --git a/ghc/compiler/rename/RnTypes.lhs b/ghc/compiler/rename/RnTypes.lhs index a7932847db..c9b232ffe0 100644 --- a/ghc/compiler/rename/RnTypes.lhs +++ b/ghc/compiler/rename/RnTypes.lhs @@ -110,7 +110,7 @@ rnHsType doc (HsTyVar tyvar) returnM (HsTyVar tyvar') rnHsType doc (HsOpTy ty1 (L loc op) ty2) - = addSrcSpan loc ( + = setSrcSpan loc ( lookupOccRn op `thenM` \ op' -> lookupTyFixityRn (L loc op') `thenM` \ fix -> rnLHsType doc ty1 `thenM` \ ty1' -> @@ -122,6 +122,10 @@ rnHsType doc (HsParTy ty) = rnLHsType doc ty `thenM` \ ty' -> returnM (HsParTy ty') +rnHsType doc (HsBangTy b ty) + = rnLHsType doc ty `thenM` \ ty' -> + returnM (HsBangTy b ty') + rnHsType doc (HsNumTy i) | i == 1 = returnM (HsNumTy i) | otherwise = addErr err_msg `thenM_` returnM (HsNumTy i) @@ -169,8 +173,8 @@ rnLHsTypes doc tys = mappM (rnLHsType doc) tys \begin{code} -rnForAll :: SDoc -> HsExplicitForAll -> [LHsTyVarBndr RdrName] -> LHsContext RdrName - -> LHsType RdrName -> RnM (HsType Name) +rnForAll :: SDoc -> HsExplicitForAll -> [LHsTyVarBndr RdrName] + -> LHsContext RdrName -> LHsType RdrName -> RnM (HsType Name) rnForAll doc exp [] (L _ []) (L _ ty) = rnHsType doc ty -- One reason for this case is that a type like Int# @@ -210,7 +214,7 @@ by the presence of -> lookupTyFixityRn (L loc n) = doptM Opt_GlasgowExts `thenM` \ glaExts -> when (not glaExts) - (addSrcSpan loc $ addWarn (infixTyConWarn n)) `thenM_` + (setSrcSpan loc $ addWarn (infixTyConWarn n)) `thenM_` lookupFixityRn n -- Building (ty1 `op1` (ty21 `op2` ty22)) @@ -531,7 +535,7 @@ checkTupSize tup_size forAllWarn doc ty (L loc tyvar) = ifOptM Opt_WarnUnusedMatches $ - addSrcSpan loc $ + setSrcSpan loc $ addWarn (sep [ptext SLIT("The universally quantified type variable") <+> quotes (ppr tyvar), nest 4 (ptext SLIT("does not appear in the type") <+> quotes (ppr ty))] $$ diff --git a/ghc/compiler/simplCore/CSE.lhs b/ghc/compiler/simplCore/CSE.lhs index 6ecd70e24d..9e40c57330 100644 --- a/ghc/compiler/simplCore/CSE.lhs +++ b/ghc/compiler/simplCore/CSE.lhs @@ -16,8 +16,6 @@ import IdInfo ( workerExists ) import CoreUtils ( hashExpr, cheapEqExpr, exprIsBig, mkAltExpr, exprIsCheap ) import DataCon ( isUnboxedTupleCon ) import Type ( tyConAppArgs ) -import Subst ( InScopeSet, uniqAway, emptyInScopeSet, - extendInScopeSet, elemInScopeSet ) import CoreSyn import VarEnv import CoreLint ( showPass, endPass ) @@ -177,7 +175,8 @@ cseExpr env (Lam b e) = let (env', b') = addBinder env b in Lam b' (cseExpr env' e) cseExpr env (Let bind e) = let (env', bind') = cseBind env bind in Let bind' (cseExpr env' e) -cseExpr env (Case scrut bndr alts) = Case scrut' bndr' (cseAlts env' scrut' bndr bndr' alts) +-- gaw 2004 +cseExpr env (Case scrut bndr ty alts) = Case scrut' bndr' ty (cseAlts env' scrut' bndr bndr' alts) where scrut' = tryForCSE env scrut (env', bndr') = addBinder env bndr diff --git a/ghc/compiler/simplCore/FloatIn.lhs b/ghc/compiler/simplCore/FloatIn.lhs index a4002a5c5b..061cd4b85d 100644 --- a/ghc/compiler/simplCore/FloatIn.lhs +++ b/ghc/compiler/simplCore/FloatIn.lhs @@ -323,10 +323,11 @@ bindings are: (a)~inside the scrutinee, (b)~inside one of the alternatives/default [default FVs always {\em first}!]. \begin{code} -fiExpr to_drop (_, AnnCase scrut case_bndr alts) +-- gaw 2004 +fiExpr to_drop (_, AnnCase scrut case_bndr ty alts) = mkCoLets' drop_here1 $ mkCoLets' drop_here2 $ - Case (fiExpr scrut_drops scrut) case_bndr + Case (fiExpr scrut_drops scrut) case_bndr ty (zipWith fi_alt alts_drops_s alts) where -- Float into the scrut and alts-considered-together just like App diff --git a/ghc/compiler/simplCore/FloatOut.lhs b/ghc/compiler/simplCore/FloatOut.lhs index ac1c29d81d..b14f04230c 100644 --- a/ghc/compiler/simplCore/FloatOut.lhs +++ b/ghc/compiler/simplCore/FloatOut.lhs @@ -330,10 +330,11 @@ floatExpr lvl (Let bind body) where bind_lvl = getBindLevel bind -floatExpr lvl (Case scrut (TB case_bndr case_lvl) alts) +-- gaw 2004 +floatExpr lvl (Case scrut (TB case_bndr case_lvl) ty alts) = case floatExpr lvl scrut of { (fse, fde, scrut') -> case floatList float_alt alts of { (fsa, fda, alts') -> - (add_stats fse fsa, fda ++ fde, Case scrut' case_bndr alts') + (add_stats fse fsa, fda ++ fde, Case scrut' case_bndr ty alts') }} where -- Use floatRhs for the alternatives, so that we diff --git a/ghc/compiler/simplCore/LiberateCase.lhs b/ghc/compiler/simplCore/LiberateCase.lhs index 466dfad4ce..8df30e1416 100644 --- a/ghc/compiler/simplCore/LiberateCase.lhs +++ b/ghc/compiler/simplCore/LiberateCase.lhs @@ -220,8 +220,9 @@ libCase env (Let bind body) where (env_body, bind') = libCaseBind env bind -libCase env (Case scrut bndr alts) - = Case (libCase env scrut) bndr (map (libCaseAlt env_alts) alts) +-- gaw 2004 +libCase env (Case scrut bndr ty alts) + = Case (libCase env scrut) bndr ty (map (libCaseAlt env_alts) alts) where env_alts = addBinders env_with_scrut [bndr] env_with_scrut = case scrut of diff --git a/ghc/compiler/simplCore/OccurAnal.lhs b/ghc/compiler/simplCore/OccurAnal.lhs index 13bd97356f..5ea95a25c5 100644 --- a/ghc/compiler/simplCore/OccurAnal.lhs +++ b/ghc/compiler/simplCore/OccurAnal.lhs @@ -648,7 +648,8 @@ occAnal env expr@(Lam _ _) env2 = env1 `addNewCands` binders -- Add in-scope binders env_body = vanillaCtxt env2 -- Body is (no longer) an RhsContext -occAnal env (Case scrut bndr alts) +-- gaw 2004 +occAnal env (Case scrut bndr ty alts) = case mapAndUnzip (occAnalAlt alt_env bndr) alts of { (alts_usage_s, alts') -> case occAnal (vanillaCtxt env) scrut of { (scrut_usage, scrut') -> -- No need for rhsCtxt @@ -658,7 +659,8 @@ occAnal env (Case scrut bndr alts) (alts_usage1, tagged_bndr) = tagBinder alts_usage' bndr total_usage = scrut_usage `combineUsageDetails` alts_usage1 in - total_usage `seq` (total_usage, Case scrut' tagged_bndr alts') }} +-- gaw 2004 + total_usage `seq` (total_usage, Case scrut' tagged_bndr ty alts') }} where alt_env = env `addNewCand` bndr diff --git a/ghc/compiler/simplCore/SetLevels.lhs b/ghc/compiler/simplCore/SetLevels.lhs index 2d95727e35..08f3d8406b 100644 --- a/ghc/compiler/simplCore/SetLevels.lhs +++ b/ghc/compiler/simplCore/SetLevels.lhs @@ -274,7 +274,8 @@ lvlExpr ctxt_lvl env (_, AnnApp fun arg) lvlMFE False ctxt_lvl env arg `thenLvl` \ arg' -> returnLvl (App fun' arg') where - lvl_fun (_, AnnCase _ _ _) = lvlMFE True ctxt_lvl env fun +-- gaw 2004 + lvl_fun (_, AnnCase _ _ _ _) = lvlMFE True ctxt_lvl env fun lvl_fun other = lvlExpr ctxt_lvl env fun -- We don't do MFE on partial applications generally, -- but we do if the function is big and hairy, like a case @@ -331,13 +332,14 @@ lvlExpr ctxt_lvl env (_, AnnLet bind body) lvlExpr ctxt_lvl new_env body `thenLvl` \ body' -> returnLvl (Let bind' body') -lvlExpr ctxt_lvl env (_, AnnCase expr case_bndr alts) +-- gaw 2004 +lvlExpr ctxt_lvl env (_, AnnCase expr case_bndr ty alts) = lvlMFE True ctxt_lvl env expr `thenLvl` \ expr' -> let alts_env = extendCaseBndrLvlEnv env expr' case_bndr incd_lvl in mapLvl (lvl_alt alts_env) alts `thenLvl` \ alts' -> - returnLvl (Case expr' (TB case_bndr incd_lvl) alts') + returnLvl (Case expr' (TB case_bndr incd_lvl) ty alts') where incd_lvl = incMinorLvl ctxt_lvl @@ -680,7 +682,7 @@ extendLvlEnv (float_lams, lvl_env, subst, id_env) prs extendCaseBndrLvlEnv (float_lams, lvl_env, subst, id_env) (Var scrut_var) case_bndr lvl = (float_lams, extendVarEnv lvl_env case_bndr lvl, - extendSubst subst case_bndr (DoneEx (Var scrut_var)), + extendIdSubst subst case_bndr (DoneEx (Var scrut_var)), extendVarEnv id_env case_bndr ([scrut_var], Var scrut_var)) extendCaseBndrLvlEnv env scrut case_bndr lvl @@ -693,7 +695,7 @@ extendPolyLvlEnv dest_lvl (float_lams, lvl_env, subst, id_env) abs_vars bndr_pai foldl add_id id_env bndr_pairs) where add_lvl env (v,v') = extendVarEnv env v' dest_lvl - add_subst env (v,v') = extendSubst env v (DoneEx (mkVarApps (Var v') abs_vars)) + add_subst env (v,v') = extendIdSubst env v (DoneEx (mkVarApps (Var v') abs_vars)) add_id env (v,v') = extendVarEnv env v ((v':abs_vars), mkVarApps (Var v') abs_vars) extendCloneLvlEnv lvl (float_lams, lvl_env, _, id_env) new_subst bndr_pairs diff --git a/ghc/compiler/simplCore/SimplCore.lhs b/ghc/compiler/simplCore/SimplCore.lhs index 8df100a3ec..db7058a54f 100644 --- a/ghc/compiler/simplCore/SimplCore.lhs +++ b/ghc/compiler/simplCore/SimplCore.lhs @@ -28,7 +28,7 @@ import SimplUtils ( simplBinders ) import SimplMonad import ErrUtils ( dumpIfSet, dumpIfSet_dyn, showPass ) import CoreLint ( endPass ) -import Subst ( mkInScopeSet ) +import VarEnv ( mkInScopeSet ) import FloatIn ( floatInwards ) import FloatOut ( floatOutwards ) import Id ( idIsFrom, idSpecialisation, setIdSpecialisation ) diff --git a/ghc/compiler/simplCore/SimplMonad.lhs b/ghc/compiler/simplCore/SimplMonad.lhs index aec3c1b09d..206e8d06aa 100644 --- a/ghc/compiler/simplCore/SimplMonad.lhs +++ b/ghc/compiler/simplCore/SimplMonad.lhs @@ -35,10 +35,9 @@ module SimplMonad ( getEnclosingCC, setEnclosingCC, -- Environments - SimplEnv, emptySimplEnv, getSubst, setSubst, - getSubstEnv, extendSubst, extendSubstList, + SimplEnv, emptySimplEnv, getSubst, setSubst, extendIdSubst, extendTvSubst, + zapSubstEnv, setSubstEnv, getTvSubst, setTvSubstEnv, getInScope, setInScope, setInScopeSet, modifyInScope, addNewInScopeIds, - setSubstEnv, zapSubstEnv, -- Floats Floats, emptyFloats, isEmptyFloats, unitFloat, addFloats, flattenFloats, @@ -59,14 +58,10 @@ import PprCore () -- Instances import CostCentre ( CostCentreStack, subsumedCCS ) import Var import VarEnv -import VarSet import OrdList import qualified Subst -import Subst ( Subst, emptySubst, substEnv, - InScopeSet, mkInScopeSet, substInScope, - isInScope - ) -import Type ( Type, isUnLiftedType ) +import Subst ( Subst, SubstResult, emptySubst, substInScope, isInScope ) +import Type ( Type, TvSubst, TvSubstEnv, isUnLiftedType ) import UniqSupply ( uniqsFromSupply, uniqFromSupply, splitUniqSupply, UniqSupply ) @@ -166,7 +161,7 @@ emptyFloats env = Floats nilOL (getInScope env) True unitFloat :: SimplEnv -> OutId -> OutExpr -> Floats -- A single non-rec float; extend the in-scope set unitFloat env var rhs = Floats (unitOL (NonRec var rhs)) - (Subst.extendInScopeSet (getInScope env) var) + (extendInScopeSet (getInScope env) var) (not (isUnLiftedType (idType var))) addFloats :: SimplEnv -> Floats @@ -625,16 +620,23 @@ setEnclosingCC env cc = env {seCC = cc} getSubst :: SimplEnv -> Subst getSubst env = seSubst env +getTvSubst :: SimplEnv -> TvSubst +getTvSubst env = Subst.getTvSubst (seSubst env) + +setTvSubstEnv :: SimplEnv -> TvSubstEnv -> SimplEnv +setTvSubstEnv env@(SimplEnv {seSubst = subst}) tv_subst_env + = env {seSubst = Subst.setTvSubstEnv subst tv_subst_env} + setSubst :: SimplEnv -> Subst -> SimplEnv setSubst env subst = env {seSubst = subst} -extendSubst :: SimplEnv -> CoreBndr -> SubstResult -> SimplEnv -extendSubst env@(SimplEnv {seSubst = subst}) var res - = env {seSubst = Subst.extendSubst subst var res} +extendIdSubst :: SimplEnv -> Id -> SubstResult -> SimplEnv +extendIdSubst env@(SimplEnv {seSubst = subst}) var res + = env {seSubst = Subst.extendIdSubst subst var res} -extendSubstList :: SimplEnv -> [CoreBndr] -> [SubstResult] -> SimplEnv -extendSubstList env@(SimplEnv {seSubst = subst}) vars ress - = env {seSubst = Subst.extendSubstList subst vars ress} +extendTvSubst :: SimplEnv -> TyVar -> Type -> SimplEnv +extendTvSubst env@(SimplEnv {seSubst = subst}) var res + = env {seSubst = Subst.extendTvSubst subst var res} --------------------- getInScope :: SimplEnv -> InScopeSet @@ -645,28 +647,25 @@ setInScope env env_with_in_scope = setInScopeSet env (getInScope env_with_in_sco setInScopeSet :: SimplEnv -> InScopeSet -> SimplEnv setInScopeSet env@(SimplEnv {seSubst = subst}) in_scope - = env {seSubst = Subst.setInScope subst in_scope} + = env {seSubst = Subst.setInScopeSet subst in_scope} addNewInScopeIds :: SimplEnv -> [CoreBndr] -> SimplEnv -- The new Ids are guaranteed to be freshly allocated addNewInScopeIds env@(SimplEnv {seSubst = subst}) vs - = env {seSubst = Subst.extendNewInScopeList subst vs} + = env {seSubst = Subst.extendInScopeIds subst vs} modifyInScope :: SimplEnv -> CoreBndr -> CoreBndr -> SimplEnv modifyInScope env@(SimplEnv {seSubst = subst}) v v' = env {seSubst = Subst.modifyInScope subst v v'} --------------------- -getSubstEnv :: SimplEnv -> SubstEnv -getSubstEnv env = substEnv (seSubst env) - -setSubstEnv :: SimplEnv -> SubstEnv -> SimplEnv -setSubstEnv env@(SimplEnv {seSubst = subst}) senv - = env {seSubst = Subst.setSubstEnv subst senv} - zapSubstEnv :: SimplEnv -> SimplEnv zapSubstEnv env@(SimplEnv {seSubst = subst}) = env {seSubst = Subst.zapSubstEnv subst} + +setSubstEnv :: SimplEnv -> Subst -> SimplEnv +setSubstEnv env@(SimplEnv {seSubst = subst}) subst_with_env + = env {seSubst = Subst.setSubstEnv subst subst_with_env} \end{code} diff --git a/ghc/compiler/simplCore/SimplUtils.lhs b/ghc/compiler/simplCore/SimplUtils.lhs index bb9deaadf5..60892770d6 100644 --- a/ghc/compiler/simplCore/SimplUtils.lhs +++ b/ghc/compiler/simplCore/SimplUtils.lhs @@ -13,7 +13,7 @@ module SimplUtils ( SimplCont(..), DupFlag(..), LetRhsFlag(..), contIsDupable, contResultType, countValArgs, countArgs, pushContArgs, - mkBoringStop, mkStop, contIsRhs, contIsRhsOrArg, + mkBoringStop, mkRhsStop, contIsRhs, contIsRhsOrArg, getContArgs, interestingCallContext, interestingArg, isStrictType ) where @@ -42,7 +42,7 @@ import TcType ( isDictTy ) import Name ( mkSysTvName ) import OccName ( EncodedFS ) import TyCon ( tyConDataCons_maybe, isAlgTyCon, isNewTyCon ) -import DataCon ( dataConRepArity, dataConExistentialTyVars, dataConArgTys ) +import DataCon ( dataConRepArity, dataConTyVars, dataConArgTys, isVanillaDataCon ) import Var ( tyVarKind, mkTyVar ) import VarSet import Util ( lengthExceeds, mapAccumL ) @@ -115,11 +115,9 @@ instance Outputable DupFlag where ------------------- -mkBoringStop :: OutType -> SimplCont +mkBoringStop, mkRhsStop :: OutType -> SimplCont mkBoringStop ty = Stop ty AnArg (canUpdateInPlace ty) - -mkStop :: OutType -> LetRhsFlag -> SimplCont -mkStop ty is_rhs = Stop ty is_rhs (canUpdateInPlace ty) +mkRhsStop ty = Stop ty AnRhs (canUpdateInPlace ty) contIsRhs :: SimplCont -> Bool contIsRhs (Stop _ AnRhs _) = True @@ -136,8 +134,8 @@ contIsDupable (Stop _ _ _) = True contIsDupable (ApplyTo OkToDup _ _ _) = True contIsDupable (Select OkToDup _ _ _ _) = True contIsDupable (CoerceIt _ cont) = contIsDupable cont -contIsDupable (InlinePlease cont) = contIsDupable cont -contIsDupable other = False +contIsDupable (InlinePlease cont) = contIsDupable cont +contIsDupable other = False ------------------- discardableCont :: SimplCont -> Bool @@ -372,9 +370,9 @@ interestingCallContext :: Bool -- False <=> no args at all interestingCallContext some_args some_val_args cont = interesting cont where - interesting (InlinePlease _) = True - interesting (Select _ _ _ _ _) = some_args - interesting (ApplyTo _ _ _ _) = True -- Can happen if we have (coerce t (f x)) y + interesting (InlinePlease _) = True + interesting (Select _ _ _ _ _) = some_args + interesting (ApplyTo _ _ _ _) = True -- Can happen if we have (coerce t (f x)) y -- Perhaps True is a bit over-keen, but I've -- seen (coerce f) x, where f has an INLINE prag, -- So we have to give some motivaiton for inlining it @@ -903,16 +901,22 @@ prepareDefault case_bndr handled_cons Nothing = returnSmpl [] mk_args missing_con inst_tys - = getUniquesSmpl `thenSmpl` \ tv_uniqs -> - getUniquesSmpl `thenSmpl` \ id_uniqs -> - let - ex_tyvars = dataConExistentialTyVars missing_con - ex_tyvars' = zipWith mk tv_uniqs ex_tyvars - mk uniq tv = mkTyVar (mkSysTvName uniq FSLIT("t")) (tyVarKind tv) - arg_tys = dataConArgTys missing_con (inst_tys ++ mkTyVarTys ex_tyvars') - arg_ids = zipWith (mkSysLocal FSLIT("a")) id_uniqs arg_tys - in - returnSmpl (ex_tyvars' ++ arg_ids) + = mk_tv_bndrs missing_con inst_tys `thenSmpl` \ (tv_bndrs, inst_tys') -> + getUniquesSmpl `thenSmpl` \ id_uniqs -> + let arg_tys = dataConArgTys missing_con inst_tys' + arg_ids = zipWith (mkSysLocal FSLIT("a")) id_uniqs arg_tys + in + returnSmpl (tv_bndrs ++ arg_ids) + +mk_tv_bndrs missing_con inst_tys + | isVanillaDataCon missing_con + = returnSmpl ([], inst_tys) + | otherwise + = getUniquesSmpl `thenSmpl` \ tv_uniqs -> + let new_tvs = zipWith mk tv_uniqs (dataConTyVars missing_con) + mk uniq tv = mkTyVar (mkSysTvName uniq FSLIT("t")) (tyVarKind tv) + in + returnSmpl (new_tvs, mkTyVarTys new_tvs) \end{code} @@ -925,11 +929,11 @@ mk_args missing_con inst_tys mkCase puts a case expression back together, trying various transformations first. \begin{code} -mkCase :: OutExpr -> OutId -> [OutAlt] -> SimplM OutExpr +mkCase :: OutExpr -> OutId -> OutType -> [OutAlt] -> SimplM OutExpr -mkCase scrut case_bndr alts +mkCase scrut case_bndr ty alts = mkAlts scrut case_bndr alts `thenSmpl` \ better_alts -> - mkCase1 scrut case_bndr better_alts + mkCase1 scrut case_bndr ty better_alts \end{code} @@ -1016,7 +1020,8 @@ mkAlts scrut outer_bndr outer_alts mkAlts' dflags scrut outer_bndr outer_alts | dopt Opt_CaseMerge dflags, (outer_alts_without_deflt, maybe_outer_deflt) <- findDefault outer_alts, - Just (Case (Var scrut_var) inner_bndr inner_alts) <- maybe_outer_deflt, +-- gaw 2004 + Just (Case (Var scrut_var) inner_bndr _ inner_alts) <- maybe_outer_deflt, scruting_same_var scrut_var = let -- Eliminate any inner alts which are shadowed by the outer ones @@ -1199,7 +1204,7 @@ I don't really know how to improve this situation. -------------------------------------------------- #ifdef DEBUG -mkCase1 scrut case_bndr [] +mkCase1 scrut case_bndr ty [] = pprTrace "mkCase1: null alts" (ppr case_bndr <+> ppr scrut) $ returnSmpl scrut #endif @@ -1208,7 +1213,7 @@ mkCase1 scrut case_bndr [] -- 1. Eliminate the case altogether if poss -------------------------------------------------- -mkCase1 scrut case_bndr [(con,bndrs,rhs)] +mkCase1 scrut case_bndr ty [(con,bndrs,rhs)] -- See if we can get rid of the case altogether -- See the extensive notes on case-elimination above -- mkCase made sure that if all the alternatives are equal, @@ -1250,7 +1255,7 @@ mkCase1 scrut case_bndr [(con,bndrs,rhs)] -- 2. Identity case -------------------------------------------------- -mkCase1 scrut case_bndr alts -- Identity case +mkCase1 scrut case_bndr ty alts -- Identity case | all identity_alt alts = tick (CaseIdentity case_bndr) `thenSmpl_` returnSmpl (re_note scrut) @@ -1280,7 +1285,8 @@ mkCase1 scrut case_bndr alts -- Identity case -------------------------------------------------- -- Catch-all -------------------------------------------------- -mkCase1 scrut bndr alts = returnSmpl (Case scrut bndr alts) +-- gaw 2004 +mkCase1 scrut bndr ty alts = returnSmpl (Case scrut bndr ty alts) \end{code} diff --git a/ghc/compiler/simplCore/Simplify.lhs b/ghc/compiler/simplCore/Simplify.lhs index 7dc3cfced2..997423d0e8 100644 --- a/ghc/compiler/simplCore/Simplify.lhs +++ b/ghc/compiler/simplCore/Simplify.lhs @@ -15,17 +15,17 @@ import SimplMonad import SimplUtils ( mkCase, mkLam, newId, prepareAlts, simplBinder, simplBinders, simplLamBndrs, simplRecBndrs, simplLetBndr, SimplCont(..), DupFlag(..), LetRhsFlag(..), - mkStop, mkBoringStop, pushContArgs, + mkRhsStop, mkBoringStop, pushContArgs, contResultType, countArgs, contIsDupable, contIsRhsOrArg, getContArgs, interestingCallContext, interestingArg, isStrictType ) -import Var ( mustHaveLocalBinding ) -import VarEnv import Id ( Id, idType, idInfo, idArity, isDataConWorkId, setIdUnfolding, isDeadBinder, - idNewDemandInfo, setIdInfo, + idNewDemandInfo, setIdInfo, setIdOccInfo, zapLamIdInfo, setOneShotLambda, ) +import MkId ( eRROR_ID ) +import Literal ( mkStringLit ) import OccName ( encodeFS ) import IdInfo ( OccInfo(..), isLoopBreaker, setArityInfo, zapDemandInfo, @@ -33,7 +33,9 @@ import IdInfo ( OccInfo(..), isLoopBreaker, occInfo ) import NewDemand ( isStrictDmd ) -import DataCon ( dataConNumInstArgs, dataConRepStrictness ) +import Unify ( coreRefineTys ) +import DataCon ( dataConTyCon, dataConRepStrictness, isVanillaDataCon ) +import TyCon ( tyConArity ) import CoreSyn import PprCore ( pprParendExpr, pprCoreExpr ) import CoreUnfold ( mkOtherCon, mkUnfolding, callSiteInline ) @@ -41,17 +43,16 @@ import CoreUtils ( exprIsDupable, exprIsTrivial, needsCaseBinding, exprIsConApp_maybe, mkPiTypes, findAlt, exprType, exprIsValue, exprOkForSpeculation, exprArity, - mkCoerce, mkCoerce2, mkSCC, mkInlineMe, mkAltExpr, applyTypeToArg + mkCoerce, mkCoerce2, mkSCC, mkInlineMe, applyTypeToArg ) import Rules ( lookupRule ) import BasicTypes ( isMarkedStrict ) import CostCentre ( currentCCS ) import Type ( isUnLiftedType, seqType, tyConAppArgs, funArgTy, - splitFunTy_maybe, splitFunTy, eqType - ) -import Subst ( mkSubst, substTy, substExpr, - isInScope, lookupIdSubst, simplIdInfo + splitFunTy_maybe, splitFunTy, eqType, substTy ) +import Subst ( SubstResult(..), emptySubst, substExpr, + substId, simplIdInfo ) import TysPrim ( realWorldStatePrimTy ) import PrelInfo ( realWorldPrimId ) import BasicTypes ( TopLevelFlag(..), isTopLevel, @@ -299,7 +300,7 @@ simplNonRecBind env bndr rhs rhs_se cont_ty thing_inside simplNonRecBind env bndr rhs rhs_se cont_ty thing_inside | preInlineUnconditionally env NotTopLevel bndr = tick (PreInlineUnconditionally bndr) `thenSmpl_` - thing_inside (extendSubst env bndr (ContEx (getSubstEnv rhs_se) rhs)) + thing_inside (extendIdSubst env bndr (ContEx (getSubst rhs_se) rhs)) | isStrictDmd (idNewDemandInfo bndr) || isStrictType (idType bndr) -- A strict let @@ -347,7 +348,9 @@ simplNonRecX env bndr new_rhs thing_inside -- because quotInt# can fail. = simplBinder env bndr `thenSmpl` \ (env, bndr') -> thing_inside env `thenSmpl` \ (floats, body) -> - returnSmpl (emptyFloats env, Case new_rhs bndr' [(DEFAULT, [], wrapFloats floats body)]) +-- gaw 2004 + let body' = wrapFloats floats body in + returnSmpl (emptyFloats env, Case new_rhs bndr' (exprType body') [(DEFAULT, [], body')]) | preInlineUnconditionally env NotTopLevel bndr -- This happens; for example, the case_bndr during case of @@ -358,7 +361,7 @@ simplNonRecX env bndr new_rhs thing_inside -- Similarly, single occurrences can be inlined vigourously -- e.g. case (f x, g y) of (a,b) -> .... -- If a,b occur once we can avoid constructing the let binding for them. - = thing_inside (extendSubst env bndr (ContEx emptySubstEnv new_rhs)) + = thing_inside (extendIdSubst env bndr (ContEx emptySubst new_rhs)) | otherwise = simplBinder env bndr `thenSmpl` \ (env, bndr') -> @@ -420,7 +423,7 @@ simplRecOrTopPair :: SimplEnv simplRecOrTopPair env top_lvl bndr bndr' rhs | preInlineUnconditionally env top_lvl bndr -- Check for unconditional inline = tick (PreInlineUnconditionally bndr) `thenSmpl_` - returnSmpl (emptyFloats env, extendSubst env bndr (ContEx (getSubstEnv env) rhs)) + returnSmpl (emptyFloats env, extendIdSubst env bndr (ContEx (getSubst env) rhs)) | otherwise = simplLazyBind env top_lvl Recursive bndr bndr' rhs env @@ -488,9 +491,9 @@ simplLazyBind env top_lvl is_rec bndr bndr1 rhs rhs_se rhs_env = setInScope rhs_se env1 is_top_level = isTopLevel top_lvl ok_float_unlifted = not is_top_level && isNonRec is_rec - rhs_cont = mkStop (idType bndr1) AnRhs + rhs_cont = mkRhsStop (idType bndr1) in - -- Simplify the RHS; note the mkStop, which tells + -- Simplify the RHS; note the mkRhsStop, which tells -- the simplifier that this is the RHS of a let. simplExprF rhs_env rhs rhs_cont `thenSmpl` \ (floats, rhs1) -> @@ -604,7 +607,7 @@ completeLazyBind env top_lvl old_bndr new_bndr new_rhs | postInlineUnconditionally env new_bndr occ_info new_rhs = -- Drop the binding tick (PostInlineUnconditionally old_bndr) `thenSmpl_` - returnSmpl (emptyFloats env, extendSubst env old_bndr (DoneEx new_rhs)) + returnSmpl (emptyFloats env, extendIdSubst env old_bndr (DoneEx new_rhs)) -- Use the substitution to make quite, quite sure that the substitution -- will happen, since we are going to discard the binding @@ -699,9 +702,9 @@ might do the same again. \begin{code} simplExpr :: SimplEnv -> CoreExpr -> SimplM CoreExpr -simplExpr env expr = simplExprC env expr (mkStop expr_ty' AnArg) +simplExpr env expr = simplExprC env expr (mkBoringStop expr_ty') where - expr_ty' = substTy (getSubst env) (exprType expr) + expr_ty' = substTy (getTvSubst env) (exprType expr) -- The type in the Stop continuation, expr_ty', is usually not used -- It's only needed when discarding continuations after finding -- a function that returns bottom. @@ -728,7 +731,8 @@ simplExprF env (Type ty) cont simplType env ty `thenSmpl` \ ty' -> rebuild env (Type ty') cont -simplExprF env (Case scrut bndr alts) cont +-- gaw 2004 +simplExprF env (Case scrut bndr case_ty alts) cont | not (switchIsOn (getSwitchChecker env) NoCaseOfCase) = -- Simplify the scrutinee with a Select continuation simplExprF env scrut (Select NoDup bndr alts env cont) @@ -739,7 +743,8 @@ simplExprF env (Case scrut bndr alts) cont simplExprC env scrut case_cont `thenSmpl` \ case_expr' -> rebuild env case_expr' cont where - case_cont = Select NoDup bndr alts env (mkBoringStop (contResultType cont)) + case_cont = Select NoDup bndr alts env (mkBoringStop case_ty') + case_ty' = substTy (getTvSubst env) case_ty -- c.f. defn of simplExpr simplExprF env (Let (Rec pairs) body) cont = simplRecBndrs env (map fst pairs) `thenSmpl` \ (env, bndrs') -> @@ -762,7 +767,7 @@ simplType :: SimplEnv -> InType -> SimplM OutType simplType env ty = seqType new_ty `seq` returnSmpl new_ty where - new_ty = substTy (getSubst env) ty + new_ty = substTy (getTvSubst env) ty \end{code} @@ -784,7 +789,7 @@ simplLam env fun cont = ASSERT( isTyVar bndr ) tick (BetaReduction bndr) `thenSmpl_` simplType (setInScope arg_se env) ty_arg `thenSmpl` \ ty_arg' -> - go (extendSubst env bndr (DoneTy ty_arg')) body body_cont + go (extendTvSubst env bndr ty_arg') body body_cont -- Ordinary beta reduction go env (Lam bndr body) cont@(ApplyTo _ arg arg_se body_cont) @@ -829,8 +834,6 @@ mkLamBndrZapper fun n_args \begin{code} simplNote env (Coerce to from) body cont = let - in_scope = getInScope env - addCoerce s1 k1 (CoerceIt t1 cont) -- coerce T1 S1 (coerce S1 K1 e) -- ==> @@ -862,7 +865,8 @@ simplNote env (Coerce to from) body cont -- But it isn't a common case. = let (t1,t2) = splitFunTy t1t2 - new_arg = mkCoerce2 s1 t1 (substExpr (mkSubst in_scope (getSubstEnv arg_se)) arg) + new_arg = mkCoerce2 s1 t1 (substExpr subst arg) + subst = getSubst (setInScope arg_se env) in ApplyTo dup new_arg (zapSubstEnv env) (addCoerce t2 s2 cont) @@ -908,12 +912,11 @@ simplNote env (CoreNote s) e cont \begin{code} simplVar env var cont - = case lookupIdSubst (getSubst env) var of + = case substId (getSubst env) var of DoneEx e -> simplExprF (zapSubstEnv env) e cont ContEx se e -> simplExprF (setSubstEnv env se) e cont - DoneId var1 occ -> WARN( not (isInScope var1 (getSubst env)) && mustHaveLocalBinding var1, - text "simplVar:" <+> ppr var ) - completeCall (zapSubstEnv env) var1 occ cont + DoneId var1 occ -> completeCall (zapSubstEnv env) var1 occ cont + -- Note [zapSubstEnv] -- The template is already simplified, so don't re-substitute. -- This is VITAL. Consider -- let x = e in @@ -1024,7 +1027,7 @@ makeThatCall orig_env var fun@(Lam _ _) args cont go env (Lam bndr body) (Type ty_arg : args) = ASSERT( isTyVar bndr ) tick (BetaReduction bndr) `thenSmpl_` - go (extendSubst env bndr (DoneTy ty_arg)) body args + go (extendTvSubst env bndr ty_arg) body args -- Ordinary beta reduction go env (Lam bndr body) (arg : args) @@ -1108,7 +1111,7 @@ simplifyArg env fn_ty (val_arg, arg_se, is_strict) cont_ty thing_inside -- have to be very careful about bogus strictness through -- floating a demanded let. = simplExprC (setInScope arg_se env) val_arg - (mkStop arg_ty AnArg) `thenSmpl` \ arg1 -> + (mkBoringStop arg_ty) `thenSmpl` \ arg1 -> thing_inside env arg1 where arg_ty = funArgTy fn_ty @@ -1237,7 +1240,8 @@ addAtomicBindsE env ((v,r):bs) thing_inside | needsCaseBinding (idType v) r = addAtomicBindsE (addNewInScopeIds env [v]) bs thing_inside `thenSmpl` \ (floats, expr) -> WARN( exprIsTrivial expr, ppr v <+> pprCoreExpr expr ) - returnSmpl (emptyFloats env, Case r v [(DEFAULT,[], wrapFloats floats expr)]) + (let body = wrapFloats floats expr in + returnSmpl (emptyFloats env, Case r v (exprType body) [(DEFAULT,[],body)])) | otherwise = addAuxiliaryBind env (NonRec v r) $ \ env -> @@ -1306,15 +1310,27 @@ rebuildCase env scrut case_bndr alts cont prepareCaseCont env better_alts cont `thenSmpl` \ (floats, (dup_cont, nondup_cont)) -> addFloats env floats $ \ env -> + let + -- The case expression is annotated with the result type of the continuation + -- This may differ from the type originally on the case. For example + -- case(T) (case(Int#) a of { True -> 1#; False -> 0# }) of + -- a# -> <blob> + -- ===> + -- let j a# = <blob> + -- in case(T) a of { True -> j 1#; False -> j 0# } + -- Note that the case that scrutinises a now returns a T not an Int# + res_ty' = contResultType dup_cont + in + -- Deal with variable scrutinee simplCaseBinder env scrut case_bndr `thenSmpl` \ (alt_env, case_bndr', zap_occ_info) -> -- Deal with the case alternatives simplAlts alt_env zap_occ_info handled_cons - case_bndr' better_alts dup_cont `thenSmpl` \ alts' -> + case_bndr' better_alts dup_cont res_ty' `thenSmpl` \ alts' -> -- Put the case back together - mkCase scrut case_bndr' alts' `thenSmpl` \ case_expr -> + mkCase scrut case_bndr' res_ty' alts' `thenSmpl` \ case_expr -> -- Notice that rebuildDone returns the in-scope set from env, not alt_env -- The case binder *not* scope over the whole returned case-expression @@ -1422,25 +1438,28 @@ simplAlts :: SimplEnv -- in the default case -> OutId -- Case binder -> [InAlt] -> SimplCont + -> OutType -- Result type -> SimplM [OutAlt] -- Includes the continuation -simplAlts env zap_occ_info handled_cons case_bndr' alts cont' +simplAlts env zap_occ_info handled_cons case_bndr' alts cont' res_ty' = mapSmpl simpl_alt alts where - inst_tys' = tyConAppArgs (idType case_bndr') + mk_rhs_env env case_bndr_unf + = modifyInScope env case_bndr' (case_bndr' `setIdUnfolding` case_bndr_unf) simpl_alt (DEFAULT, _, rhs) - = let - -- In the default case we record the constructors that the - -- case-binder *can't* be. - -- We take advantage of any OtherCon info in the case scrutinee - case_bndr_w_unf = case_bndr' `setIdUnfolding` mkOtherCon handled_cons - env_with_unf = modifyInScope env case_bndr' case_bndr_w_unf - in - simplExprC env_with_unf rhs cont' `thenSmpl` \ rhs' -> + = let unf = mkOtherCon handled_cons in + -- Record the constructors that the case-binder *can't* be. + simplExprC (mk_rhs_env env unf) rhs cont' `thenSmpl` \ rhs' -> returnSmpl (DEFAULT, [], rhs') - simpl_alt (con, vs, rhs) + simpl_alt (LitAlt lit, _, rhs) + = let unf = mkUnfolding False (Lit lit) in + simplExprC (mk_rhs_env env unf) rhs cont' `thenSmpl` \ rhs' -> + returnSmpl (LitAlt lit, [], rhs') + + simpl_alt (DataAlt con, vs, rhs) + | isVanillaDataCon con = -- Deal with the pattern-bound variables -- Mark the ones that are in ! positions in the data constructor -- as certainly-evaluated. @@ -1450,13 +1469,34 @@ simplAlts env zap_occ_info handled_cons case_bndr' alts cont' simplBinders env (add_evals con vs) `thenSmpl` \ (env, vs') -> -- Bind the case-binder to (con args) - let - unfolding = mkUnfolding False (mkAltExpr con vs' inst_tys') - env_with_unf = modifyInScope env case_bndr' (case_bndr' `setIdUnfolding` unfolding) + let unf = mkUnfolding False (mkConApp con con_args) + inst_tys' = tyConAppArgs (idType case_bndr') + con_args = map Type inst_tys' ++ map varToCoreExpr vs' in - simplExprC env_with_unf rhs cont' `thenSmpl` \ rhs' -> - returnSmpl (con, vs', rhs') - + simplExprC (mk_rhs_env env unf) rhs cont' `thenSmpl` \ rhs' -> + returnSmpl (DataAlt con, vs', rhs') + + + | otherwise -- GADT case + = simplBinders env (add_evals con vs) `thenSmpl` \ (env, vs') -> + let unf = mkUnfolding False con_app + con_app = mkConApp con con_args + con_args = map varToCoreExpr vs' -- NB: no inst_tys' + pat_res_ty = exprType con_app + env_w_unf = mk_rhs_env env unf + tv_subst = getTvSubst env + in + case coreRefineTys vs' tv_subst pat_res_ty (idType case_bndr') of + Just tv_subst_env -> + simplExprC (setTvSubstEnv env_w_unf tv_subst_env) rhs cont' `thenSmpl` \ rhs' -> + returnSmpl (DataAlt con, vs', rhs') + Nothing -> -- Dead code; for now, I'm just going to put in an + -- error case so I can see them + let rhs' = mkApps (Var eRROR_ID) + [Type (substTy tv_subst (exprType rhs)), + Lit (mkStringLit "Impossible alternative (GADT)")] + in + returnSmpl (DataAlt con, vs', rhs') -- add_evals records the evaluated-ness of the bound variables of -- a case pattern. This is *important*. Consider @@ -1467,15 +1507,14 @@ simplAlts env zap_occ_info handled_cons case_bndr' alts cont' -- We really must record that b is already evaluated so that we don't -- go and re-evaluate it when constructing the result. - add_evals (DataAlt dc) vs = cat_evals dc vs (dataConRepStrictness dc) - add_evals other_con vs = vs + add_evals dc vs = cat_evals dc vs (dataConRepStrictness dc) cat_evals dc vs strs = go vs strs where go [] [] = [] + go (v:vs) strs | isTyVar v = v : go vs strs go (v:vs) (str:strs) - | isTyVar v = v : go vs (str:strs) | isMarkedStrict str = evald_v : go vs strs | otherwise = zapped_v : go vs strs where @@ -1527,25 +1566,31 @@ knownCon env con args bndr alts cont simplNonRecX env bndr (Lit lit) $ \ env -> simplExprF env rhs cont - (DataAlt dc, bs, rhs) -> ASSERT( length bs + n_tys == length args ) - bind_args env bs (drop n_tys args) $ \ env -> - let - con_app = mkConApp dc (take n_tys args ++ con_args) - con_args = [substExpr (getSubst env) (varToCoreExpr b) | b <- bs] + (DataAlt dc, bs, rhs) + -> ASSERT( n_drop_tys + length bs == length args ) + bind_args env bs (drop n_drop_tys args) $ \ env -> + let + con_app = mkConApp dc (take n_drop_tys args ++ con_args) + con_args = [substExpr (getSubst env) (varToCoreExpr b) | b <- bs] -- args are aready OutExprs, but bs are InIds - in - simplNonRecX env bndr con_app $ \ env -> - simplExprF env rhs cont - where - n_tys = dataConNumInstArgs dc -- Non-existential type args + in + simplNonRecX env bndr con_app $ \ env -> + simplExprF env rhs cont + where + n_drop_tys | isVanillaDataCon dc = tyConArity (dataConTyCon dc) + | otherwise = 0 + -- Vanilla data constructors lack type arguments in the pattern + -- Ugh! bind_args env [] _ thing_inside = thing_inside env bind_args env (b:bs) (Type ty : args) thing_inside - = bind_args (extendSubst env b (DoneTy ty)) bs args thing_inside + = ASSERT( isTyVar b ) + bind_args (extendTvSubst env b ty) bs args thing_inside bind_args env (b:bs) (arg : args) thing_inside - = simplNonRecX env b arg $ \ env -> + = ASSERT( isId b ) + simplNonRecX env b arg $ \ env -> bind_args env bs args thing_inside \end{code} @@ -1639,7 +1684,7 @@ mkDupableCont env (ApplyTo _ arg se cont) -- This has been this way for a long time, so I'll leave it, -- but I can't convince myself that it's right. - +-- gaw 2004 mkDupableCont env (Select _ case_bndr alts se cont) = -- e.g. (case [...hole...] of { pi -> ei }) -- ===> diff --git a/ghc/compiler/specialise/Rules.lhs b/ghc/compiler/specialise/Rules.lhs index 4f53859920..5f63dac550 100644 --- a/ghc/compiler/specialise/Rules.lhs +++ b/ghc/compiler/specialise/Rules.lhs @@ -20,16 +20,17 @@ import CoreFVs ( exprFreeVars, ruleRhsFreeVars ) import CoreUnfold ( isCheapUnfolding, unfoldingTemplate ) import CoreUtils ( eqExpr ) import CoreTidy ( pprTidyIdRules ) -import Subst ( Subst, InScopeSet, mkInScopeSet, lookupSubst, extendSubst, - substEnv, setSubstEnv, emptySubst, isInScope, emptyInScopeSet, - bindSubstList, unBindSubstList, substInScope, uniqAway +import Subst ( Subst, SubstResult(..), extendIdSubst, + getTvSubstEnv, setTvSubstEnv, + emptySubst, isInScope, lookupIdSubst, lookupTvSubst, + bindSubstList, unBindSubstList, substInScope ) import Id ( Id, idUnfolding, idSpecialisation, setIdSpecialisation ) -import Var ( isId ) +import Var ( Var, isId ) import VarSet import VarEnv import TcType ( mkTyVarTy ) -import qualified TcType ( match ) +import qualified Unify ( matchTyX ) import BasicTypes ( Activation, CompilerPhase, isActive ) import Outputable @@ -171,13 +172,19 @@ matchRule is_active in_scope rule@(Rule rn act tpl_vars tpl_args rhs) args ----------------------- app_match subst fn vs = foldl go fn vs - where - senv = substEnv subst - go fn v = case lookupSubstEnv senv v of - Just (DoneEx ex) -> fn `App` ex - Just (DoneTy ty) -> fn `App` Type ty - -- Substitution should bind them all! - + where + go fn v = case lookupVar subst v of + Just e -> fn `App` e + Nothing -> pprPanic "app_match: unbound tpl" (ppr v) + +lookupVar :: Subst -> Var -> Maybe CoreExpr +lookupVar subst v + | isId v = case lookupIdSubst subst v of + Just (DoneEx ex) -> Just ex + other -> Nothing + | otherwise = case lookupTvSubst subst v of + Just ty -> Just (Type ty) + Nothing -> Nothing ----------------------- {- The code below tries to match even if there are more @@ -229,10 +236,13 @@ type Matcher result = VarSet -- Template variables -> Subst -> Maybe result -- Substitution so far -> result -- The *SubstEnv* in these Substs apply to the TEMPLATE only --- The *InScopeSet* in these Substs gives variables bound so far in the +-- The *InScopeSet* in these Substs is HIJACKED, +-- to give the set of variables bound so far in the -- target term. So when matching forall a. (\x. a x) against (\y. y y) -- while processing the body of the lambdas, the in-scope set will be {y}. -- That lets us do the occurs-check when matching 'a' against 'y' +-- +-- It starts off empty match :: CoreExpr -- Template -> CoreExpr -- Target @@ -240,14 +250,18 @@ match :: CoreExpr -- Template match_fail = Nothing -match (Var v1) e2 tpl_vars kont subst - = case lookupSubst subst v1 of +-- ToDo: remove this debugging junk +-- match e1 e2 tpls kont subst = pprTrace "match" (ppr e1 <+> ppr e2 <+> ppr subst) $ match_ e1 e2 tpls kont subst +match = match_ + +match_ (Var v1) e2 tpl_vars kont subst + = case lookupIdSubst subst v1 of Nothing | v1 `elemVarSet` tpl_vars -- v1 is a template variable -> if (any (`isInScope` subst) (varSetElems (exprFreeVars e2))) then match_fail -- Occurs check failure -- e.g. match forall a. (\x-> a x) against (\y. y y) else - kont (extendSubst subst v1 (DoneEx e2)) + kont (extendIdSubst subst v1 (DoneEx e2)) | eqExpr (Var v1) e2 -> kont subst @@ -257,27 +271,32 @@ match (Var v1) e2 tpl_vars kont subst other -> match_fail -match (Lit lit1) (Lit lit2) tpl_vars kont subst +match_ (Lit lit1) (Lit lit2) tpl_vars kont subst | lit1 == lit2 = kont subst -match (App f1 a1) (App f2 a2) tpl_vars kont subst +match_ (App f1 a1) (App f2 a2) tpl_vars kont subst = match f1 f2 tpl_vars (match a1 a2 tpl_vars kont) subst -match (Lam x1 e1) (Lam x2 e2) tpl_vars kont subst +match_ (Lam x1 e1) (Lam x2 e2) tpl_vars kont subst = bind [x1] [x2] (match e1 e2) tpl_vars kont subst -- This rule does eta expansion -- (\x.M) ~ N iff M ~ N x -- See assumption A3 -match (Lam x1 e1) e2 tpl_vars kont subst +match_ (Lam x1 e1) e2 tpl_vars kont subst = bind [x1] [x1] (match e1 (App e2 (mkVarArg x1))) tpl_vars kont subst -- Eta expansion the other way -- M ~ (\y.N) iff \y.M y ~ \y.N -- iff M y ~ N -- Remembering that by (A), y can't be free in M, we get this -match e1 (Lam x2 e2) tpl_vars kont subst +match_ e1 (Lam x2 e2) tpl_vars kont subst + | new_id == x2 -- If the two are equal, don't bind, else we get + -- a substitution looking like x->x, and that sends + -- Unify.matchTy into a loop + = match (App e1 (mkVarArg new_id)) e2 tpl_vars kont subst + | otherwise = bind [new_id] [x2] (match (App e1 (mkVarArg new_id)) e2) tpl_vars kont subst where new_id = uniqAway (substInScope subst) x2 @@ -289,16 +308,18 @@ match e1 (Lam x2 e2) tpl_vars kont subst -- The first \x is ok, but when we inline k, hoping it might -- match (:) we find a second \x. -match (Case e1 x1 alts1) (Case e2 x2 alts2) tpl_vars kont subst - = match e1 e2 tpl_vars case_kont subst +-- gaw 2004 +match_ (Case e1 x1 ty1 alts1) (Case e2 x2 ty2 alts2) tpl_vars kont subst + = (match_ty ty1 ty2 tpl_vars $ + match e1 e2 tpl_vars case_kont) subst where case_kont subst = bind [x1] [x2] (match_alts alts1 (sortLe le_alt alts2)) tpl_vars kont subst -match (Type ty1) (Type ty2) tpl_vars kont subst +match_ (Type ty1) (Type ty2) tpl_vars kont subst = match_ty ty1 ty2 tpl_vars kont subst -match (Note (Coerce to1 from1) e1) (Note (Coerce to2 from2) e2) +match_ (Note (Coerce to1 from1) e1) (Note (Coerce to2 from2) e2) tpl_vars kont subst = (match_ty to1 to2 tpl_vars $ match_ty from1 from2 tpl_vars $ @@ -325,7 +346,7 @@ match e1 (Let bind e2) tpl_vars kont subst -- variable, we expand it so long as its unfolding is a WHNF -- (Its occurrence information is not necessarily up to date, -- so we don't use it.) -match e1 (Var v2) tpl_vars kont subst +match_ e1 (Var v2) tpl_vars kont subst | isCheapUnfolding unfolding = match e1 (unfoldingTemplate unfolding) tpl_vars kont subst where @@ -334,7 +355,7 @@ match e1 (Var v2) tpl_vars kont subst -- We can't cope with lets in the template -match e1 e2 tpl_vars kont subst = match_fail +match_ e1 e2 tpl_vars kont subst = match_fail ------------------------------------------ @@ -368,7 +389,7 @@ bind vs1 vs2 matcher tpl_vars kont subst subst' = bindSubstList subst vs1 vs2 -- The unBindSubst relies on no shadowing in the template - not_in_subst v = isNothing (lookupSubst subst v) + not_in_subst v = isNothing (lookupVar subst v) bug_msg = sep [ppr vs1, ppr vs2] ---------------------------------------- @@ -386,9 +407,9 @@ We only want to replace (f T) with f', not (f Int). \begin{code} ---------------------------------------- match_ty ty1 ty2 tpl_vars kont subst - = TcType.match ty1 ty2 tpl_vars kont' (substEnv subst) - where - kont' senv = kont (setSubstEnv subst senv) + = case Unify.matchTyX tpl_vars (getTvSubstEnv subst) ty1 ty2 of + Just tv_env' -> kont (setTvSubstEnv subst tv_env') + Nothing -> match_fail \end{code} @@ -514,8 +535,9 @@ ruleCheck env (App f a) = ruleCheckApp env (App f a) [] ruleCheck env (Note n e) = ruleCheck env e ruleCheck env (Let bd e) = ruleCheckBind env bd `unionBags` ruleCheck env e ruleCheck env (Lam b e) = ruleCheck env e -ruleCheck env (Case e _ as) = ruleCheck env e `unionBags` - unionManyBags [ruleCheck env r | (_,_,r) <- as] +-- gaw 2004 +ruleCheck env (Case e _ _ as) = ruleCheck env e `unionBags` + unionManyBags [ruleCheck env r | (_,_,r) <- as] ruleCheckApp env (App f a) as = ruleCheck env a `unionBags` ruleCheckApp env f (a:as) ruleCheckApp env (Var f) as = ruleCheckFun env f as diff --git a/ghc/compiler/specialise/SpecConstr.lhs b/ghc/compiler/specialise/SpecConstr.lhs index 603c2a684e..c7824cadff 100644 --- a/ghc/compiler/specialise/SpecConstr.lhs +++ b/ghc/compiler/specialise/SpecConstr.lhs @@ -335,11 +335,13 @@ scExpr env (Note n e) = scExpr env e `thenUs` \ (usg,e') -> scExpr env (Lam b e) = scExpr (extendBndr env b) e `thenUs` \ (usg,e') -> returnUs (usg, Lam b e') -scExpr env (Case scrut b alts) +-- gaw 2004 +scExpr env (Case scrut b ty alts) = sc_scrut scrut `thenUs` \ (scrut_usg, scrut') -> mapAndUnzipUs sc_alt alts `thenUs` \ (alts_usgs, alts') -> +-- gaw 2004 returnUs (combineUsages alts_usgs `combineUsage` scrut_usg, - Case scrut' b alts') + Case scrut' b ty alts') where sc_scrut e@(Var v) = returnUs (varUsage env v CaseScrut, e) sc_scrut e = scExpr env e diff --git a/ghc/compiler/specialise/Specialise.lhs b/ghc/compiler/specialise/Specialise.lhs index 1d172e9728..752e68264e 100644 --- a/ghc/compiler/specialise/Specialise.lhs +++ b/ghc/compiler/specialise/Specialise.lhs @@ -14,10 +14,10 @@ import TcType ( Type, mkTyVarTy, tcSplitSigmaTy, tyVarsOfTypes, tyVarsOfTheta, isClassPred, mkForAllTys, tcCmpType ) -import Subst ( Subst, mkSubst, substTy, mkSubst, extendSubstList, mkInScopeSet, - simplBndr, simplBndrs, +import Subst ( Subst, SubstResult(..), mkSubst, mkSubst, extendTvSubstList, + simplBndr, simplBndrs, substTy, substAndCloneId, substAndCloneIds, substAndCloneRecIds, - lookupIdSubst, substInScope + substId, substInScope ) import Var ( zapSpecPragmaId ) import VarSet @@ -595,7 +595,7 @@ specProgram dflags us binds -- 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 (mkInScopeSet (mkVarSet (bindersOfBinds binds))) emptySubstEnv + top_subst = mkSubst (mkInScopeSet (mkVarSet (bindersOfBinds binds))) go [] = returnSM ([], emptyUDs) go (bind:binds) = go binds `thenSM` \ (binds', uds) -> @@ -611,7 +611,7 @@ specProgram dflags us binds \begin{code} specVar :: Subst -> Id -> CoreExpr -specVar subst v = case lookupIdSubst subst v of +specVar subst v = case substId subst v of DoneEx e -> e DoneId v _ -> Var v @@ -658,10 +658,11 @@ specExpr subst e@(Lam _ _) -- More efficient to collect a group of binders together all at once -- and we don't want to split a lambda group with dumped bindings -specExpr subst (Case scrut case_bndr alts) +-- gaw 2004 +specExpr subst (Case scrut case_bndr ty alts) = specExpr subst scrut `thenSM` \ (scrut', uds_scrut) -> mapAndCombineSM spec_alt alts `thenSM` \ (alts', uds_alts) -> - returnSM (Case scrut' case_bndr' alts', uds_scrut `plusUDs` uds_alts) + returnSM (Case scrut' case_bndr' (substTy subst ty) alts', uds_scrut `plusUDs` uds_alts) where (subst_alt, case_bndr') = simplBndr subst case_bndr -- No need to clone case binder; it can't float like a let(rec) @@ -871,7 +872,7 @@ specDefn subst calls (fn, rhs) where mk_ty_arg rhs_tyvar Nothing = Type (mkTyVarTy rhs_tyvar) mk_ty_arg rhs_tyvar (Just ty) = Type ty - rhs_subst = extendSubstList subst spec_tyvars [DoneTy ty | Just ty <- call_ts] + rhs_subst = extendTvSubstList subst (spec_tyvars `zip` [ty | Just ty <- call_ts]) in cloneBinders rhs_subst rhs_dicts `thenSM` \ (rhs_subst', rhs_dicts') -> let diff --git a/ghc/compiler/stgSyn/CoreToStg.lhs b/ghc/compiler/stgSyn/CoreToStg.lhs index 2f59489e0a..61e67df57c 100644 --- a/ghc/compiler/stgSyn/CoreToStg.lhs +++ b/ghc/compiler/stgSyn/CoreToStg.lhs @@ -330,7 +330,8 @@ coreToStgExpr (Note other_note expr) -- Cases require a little more real work. -coreToStgExpr (Case scrut bndr alts) +-- gaw 2004 +coreToStgExpr (Case scrut bndr _ alts) = extendVarEnvLne [(bndr, LambdaBound)] ( mapAndUnzip3Lne vars_alt alts `thenLne` \ (alts2, fvs_s, escs_s) -> returnLne ( alts2, @@ -1021,12 +1022,12 @@ lookupFVInfo fvs id Just (_,_,info) -> info allFreeIds :: FreeVarsInfo -> [(Id,HowBound)] -- Both top level and non-top-level Ids -allFreeIds fvs = [(id,how_bound) | (id,how_bound,_) <- rngVarEnv fvs, isId id] +allFreeIds fvs = [(id,how_bound) | (id,how_bound,_) <- varEnvElts fvs, isId id] -- Non-top-level things only, both type variables and ids -- (type variables only if opt_RuntimeTypes) getFVs :: FreeVarsInfo -> [Var] -getFVs fvs = [id | (id, how_bound, _) <- rngVarEnv fvs, +getFVs fvs = [id | (id, how_bound, _) <- varEnvElts fvs, not (topLevelBound how_bound) ] getFVSet :: FreeVarsInfo -> VarSet diff --git a/ghc/compiler/stranal/DmdAnal.lhs b/ghc/compiler/stranal/DmdAnal.lhs index 2c6f3941bc..12b25bc7ca 100644 --- a/ghc/compiler/stranal/DmdAnal.lhs +++ b/ghc/compiler/stranal/DmdAnal.lhs @@ -204,7 +204,8 @@ dmdAnal sigs dmd (Lam var body) in (deferType lam_ty, Lam var' body') -dmdAnal sigs dmd (Case scrut case_bndr [alt@(DataAlt dc,bndrs,rhs)]) +-- gaw 2004 +dmdAnal sigs dmd (Case scrut case_bndr ty [alt@(DataAlt dc,bndrs,rhs)]) | let tycon = dataConTyCon dc, isProductTyCon tycon, not (isRecursiveTyCon tycon) @@ -250,16 +251,19 @@ dmdAnal sigs dmd (Case scrut case_bndr [alt@(DataAlt dc,bndrs,rhs)]) (scrut_ty, scrut') = dmdAnal sigs scrut_dmd scrut in - (alt_ty1 `bothType` scrut_ty, Case scrut' case_bndr' [alt']) +-- gaw 2004 + (alt_ty1 `bothType` scrut_ty, Case scrut' case_bndr' ty [alt']) -dmdAnal sigs dmd (Case scrut case_bndr alts) +-- gaw 2004 +dmdAnal sigs dmd (Case scrut case_bndr ty alts) = let (alt_tys, alts') = mapAndUnzip (dmdAnalAlt sigs dmd) alts (scrut_ty, scrut') = dmdAnal sigs evalDmd scrut (alt_ty, case_bndr') = annotateBndr (foldr1 lubType alt_tys) case_bndr in -- pprTrace "dmdAnal:Case" (ppr alts $$ ppr alt_tys) - (alt_ty `bothType` scrut_ty, Case scrut' case_bndr' alts') +-- gaw 2004 + (alt_ty `bothType` scrut_ty, Case scrut' case_bndr' ty alts') dmdAnal sigs dmd (Let (NonRec id rhs) body) = let diff --git a/ghc/compiler/stranal/WorkWrap.lhs b/ghc/compiler/stranal/WorkWrap.lhs index 8b889970c9..276d8da52f 100644 --- a/ghc/compiler/stranal/WorkWrap.lhs +++ b/ghc/compiler/stranal/WorkWrap.lhs @@ -158,10 +158,12 @@ wwExpr (Let bind expr) wwExpr expr `thenUs` \ new_expr -> returnUs (mkLets intermediate_bind new_expr) -wwExpr (Case expr binder alts) +-- gaw 2004 +wwExpr (Case expr binder ty alts) = wwExpr expr `thenUs` \ new_expr -> mapUs ww_alt alts `thenUs` \ new_alts -> - returnUs (Case new_expr binder new_alts) +-- gaw 2004 + returnUs (Case new_expr binder ty new_alts) where ww_alt (con, binders, rhs) = wwExpr rhs `thenUs` \ new_rhs -> diff --git a/ghc/compiler/stranal/WwLib.lhs b/ghc/compiler/stranal/WwLib.lhs index e1a1da6463..b84f9c60b3 100644 --- a/ghc/compiler/stranal/WwLib.lhs +++ b/ghc/compiler/stranal/WwLib.lhs @@ -429,8 +429,9 @@ mkWWcpr body_ty RetCPR arg = mk_ww_local arg_uniq con_arg_ty1 con_app = mkConApp data_con (map Type tycon_arg_tys ++ [Var arg]) in - returnUs (\ wkr_call -> Case wkr_call arg [(DEFAULT, [], con_app)], - \ body -> workerCase body work_wild [(DataAlt data_con, [arg], Var arg)], +-- gaw 2004 + returnUs (\ wkr_call -> Case wkr_call arg (exprType con_app) [(DEFAULT, [], con_app)], + \ body -> workerCase body work_wild con_arg_ty1 [(DataAlt data_con, [arg], Var arg)], con_arg_ty1) | otherwise -- The general case @@ -445,8 +446,9 @@ mkWWcpr body_ty RetCPR 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) in - returnUs (\ wkr_call -> Case wkr_call wrap_wild [(DataAlt ubx_tup_con, args, con_app)], - \ body -> workerCase body work_wild [(DataAlt data_con, args, ubx_tup_app)], +-- gaw 2004 + returnUs (\ wkr_call -> Case wkr_call wrap_wild (exprType con_app) [(DataAlt ubx_tup_con, args, con_app)], + \ body -> workerCase body work_wild ubx_tup_ty [(DataAlt data_con, args, ubx_tup_app)], ubx_tup_ty) where (_, tycon_arg_tys, data_con, con_arg_tys) = splitProductType "mkWWcpr" body_ty @@ -467,8 +469,10 @@ mkWWcpr body_ty other -- No CPR info -- This transform doesn't move work or allocation -- from one cost centre to another -workerCase (Note (SCC cc) e) arg alts = Note (SCC cc) (Case e arg alts) -workerCase e arg alts = Case e arg alts +-- gaw 2004 +workerCase (Note (SCC cc) e) arg ty alts = Note (SCC cc) (Case e arg ty alts) +-- gaw 2004 +workerCase e arg ty alts = Case e arg ty alts \end{code} @@ -494,9 +498,12 @@ mk_unpk_case arg unpk_args boxing_con boxing_tycon body -- A data type = Case (Var arg) (sanitiseCaseBndr arg) +-- gaw 2004 + (exprType body) [(DataAlt boxing_con, unpk_args, body)] -mk_seq_case arg body = Case (Var arg) (sanitiseCaseBndr arg) [(DEFAULT, [], body)] +-- gaw 2004 +mk_seq_case arg body = Case (Var arg) (sanitiseCaseBndr arg) (exprType body) [(DEFAULT, [], body)] sanitiseCaseBndr :: Id -> Id -- The argument we are scrutinising has the right type to be diff --git a/ghc/compiler/typecheck/Inst.lhs b/ghc/compiler/typecheck/Inst.lhs index c8a50d0be1..0803e56226 100644 --- a/ghc/compiler/typecheck/Inst.lhs +++ b/ghc/compiler/typecheck/Inst.lhs @@ -12,10 +12,10 @@ module Inst ( tidyInsts, tidyMoreInsts, - newDictsFromOld, newDicts, cloneDict, + newDictsFromOld, newDicts, newDictsAtLoc, cloneDict, newOverloadedLit, newIPDict, newMethod, newMethodFromName, newMethodWithGivenTy, - tcInstClassOp, tcInstCall, tcInstDataCon, + tcInstClassOp, tcInstCall, tcInstStupidTheta, tcSyntaxName, tcStdSyntaxName, tyVarsOfInst, tyVarsOfInsts, tyVarsOfLIE, @@ -53,38 +53,39 @@ import TcIface ( loadImportedInsts ) import TcMType ( zonkTcType, zonkTcTypes, zonkTcPredType, zonkTcThetaType, tcInstTyVar, tcInstType, tcInstTyVars ) -import TcType ( Type, TcType, TcThetaType, TcTyVarSet, - PredType(..), TyVarDetails(VanillaTv), typeKind, - tcSplitForAllTys, tcSplitForAllTys, mkTyConApp, +import TcType ( Type, TcType, TcThetaType, TcTyVarSet, TcTyVar, + PredType(..), typeKind, + tcSplitForAllTys, tcSplitForAllTys, tcSplitPhiTy, tcIsTyVarTy, tcSplitDFunTy, isIntTy,isFloatTy, isIntegerTy, isDoubleTy, tcIsTyVarTy, mkPredTy, mkTyVarTy, mkTyVarTys, tyVarsOfType, tyVarsOfTypes, tyVarsOfPred, tidyPred, isClassPred, isTyVarClassPred, isLinearPred, getClassPredTys, getClassPredTys_maybe, mkPredName, - isInheritablePred, isIPPred, matchTys, + isInheritablePred, isIPPred, tidyType, tidyTypes, tidyFreeTyVars, tcSplitSigmaTy, pprPred, pprParendType, pprThetaArrow, pprTheta, pprClassPred ) +import Type ( substTy, substTys, substTyWith, substTheta, zipTopTvSubst ) +import Unify ( matchTys ) import Kind ( isSubKind ) import HscTypes ( ExternalPackageState(..) ) import CoreFVs ( idFreeTyVars ) -import DataCon ( DataCon,dataConSig ) +import DataCon ( DataCon, dataConTyVars, dataConStupidTheta, dataConName ) import Id ( Id, idName, idType, mkUserLocal, mkSysLocal, mkLocalId, setIdUnique ) import PrelInfo ( isStandardClass, isNoDictClass ) import Name ( Name, mkMethodOcc, getOccName, getSrcLoc, isHomePackageName, isInternalName ) import NameSet ( addOneToNameSet ) -import Subst ( substTy, substTyWith, substTheta, mkTopTyVarSubst ) import Literal ( inIntRange ) import Var ( TyVar, tyVarKind ) -import VarEnv ( TidyEnv, emptyTidyEnv, lookupSubstEnv, SubstResult(..) ) +import VarEnv ( TidyEnv, emptyTidyEnv, lookupVarEnv ) import VarSet ( elemVarSet, emptyVarSet, unionVarSet, mkVarSet ) import TysWiredIn ( floatDataCon, doubleDataCon ) import PrelNames ( integerTyConName, fromIntegerName, fromRationalName, rationalTyConName ) import BasicTypes( IPName(..), mapIPName, ipNameName ) import UniqSupply( uniqsFromSupply ) import SrcLoc ( mkSrcSpan, noLoc, unLoc, Located(..) ) -import CmdLineOpts( DynFlags, DynFlag( Opt_AllowUndecidableInstances ), dopt ) +import CmdLineOpts( DynFlags ) import Maybes ( isJust ) import Outputable \end{code} @@ -267,53 +268,28 @@ newIPDict orig ip_name ty \begin{code} -tcInstCall :: InstOrigin -> TcType -> TcM (ExprCoFn, TcType) +tcInstCall :: InstOrigin -> TcType -> TcM (ExprCoFn, [TcTyVar], TcType) tcInstCall orig fun_ty -- fun_ty is usually a sigma-type - = tcInstType VanillaTv fun_ty `thenM` \ (tyvars, theta, tau) -> - newDicts orig theta `thenM` \ dicts -> - extendLIEs dicts `thenM_` - let - inst_fn e = DictApp (mkHsTyApp (noLoc e) (mkTyVarTys tyvars)) (map instToId dicts) - in - returnM (mkCoercion inst_fn, tau) - -tcInstDataCon :: InstOrigin - -> TyVarDetails -- Use this for the existential tyvars - -- ExistTv when pattern-matching, - -- VanillaTv at a call of the constructor - -> DataCon - -> TcM ([TcType], -- Types to instantiate at - [Inst], -- Existential dictionaries to apply to - [TcType], -- Argument types of constructor - TcType, -- Result type - [TyVar]) -- Existential tyvars -tcInstDataCon orig ex_tv_details data_con - = let - (tvs, stupid_theta, ex_tvs, ex_theta, arg_tys, tycon) = dataConSig data_con - -- We generate constraints for the stupid theta even when - -- pattern matching (as the Report requires) - in - mappM (tcInstTyVar VanillaTv) tvs `thenM` \ tvs' -> - mappM (tcInstTyVar ex_tv_details) ex_tvs `thenM` \ ex_tvs' -> - let - tv_tys' = mkTyVarTys tvs' - ex_tv_tys' = mkTyVarTys ex_tvs' - all_tys' = tv_tys' ++ ex_tv_tys' - - tenv = mkTopTyVarSubst (tvs ++ ex_tvs) all_tys' - stupid_theta' = substTheta tenv stupid_theta - ex_theta' = substTheta tenv ex_theta - arg_tys' = map (substTy tenv) arg_tys - result_ty' = mkTyConApp tycon tv_tys' - in - newDicts orig stupid_theta' `thenM` \ stupid_dicts -> - newDicts orig ex_theta' `thenM` \ ex_dicts -> - - -- Note that we return the stupid theta *only* in the LIE; - -- we don't otherwise use it at all - extendLIEs stupid_dicts `thenM_` - - returnM (all_tys', ex_dicts, arg_tys', result_ty', ex_tvs') + = do { (tyvars, theta, tau) <- tcInstType fun_ty + ; dicts <- newDicts orig theta + ; extendLIEs dicts + ; let inst_fn e = unLoc (mkHsDictApp (mkHsTyApp (noLoc e) (mkTyVarTys tyvars)) + (map instToId dicts)) + ; return (mkCoercion inst_fn, tyvars, tau) } + +tcInstStupidTheta :: DataCon -> [TcType] -> TcM () +-- Instantiate the "stupid theta" of the data con, and throw +-- the constraints into the constraint set +tcInstStupidTheta data_con inst_tys + | null stupid_theta + = return () + | otherwise + = do { stupid_dicts <- newDicts (OccurrenceOf (dataConName data_con)) + (substTheta tenv stupid_theta) + ; extendLIEs stupid_dicts } + where + stupid_theta = dataConStupidTheta data_con + tenv = zipTopTvSubst (dataConTyVars data_con) inst_tys newMethodFromName :: InstOrigin -> TcType -> Name -> TcM TcId newMethodFromName origin ty name @@ -363,7 +339,7 @@ checkKind tv ty then return () else do { traceTc (text "checkKind: adding kind constraint" <+> ppr tv <+> ppr ty) - ; tv1 <- tcInstTyVar VanillaTv tv + ; tv1 <- tcInstTyVar tv ; unifyTauTy (mkTyVarTy tv1) ty1 }} @@ -542,8 +518,6 @@ pprDFuns dfuns = vcat [ hang (ppr (getSrcLoc dfun) <> colon) , let (_, theta, clas, tys) = tcSplitDFunTy (idType dfun) ] -- Print without the for-all, which the programmer doesn't write -show_uniq u = ifPprDebug (text "{-" <> ppr u <> text "-}") - tidyInst :: TidyEnv -> Inst -> Inst tidyInst env (LitInst u lit ty loc) = LitInst u lit (tidyType env ty) loc tidyInst env (Dict u pred loc) = Dict u (tidyPred env pred) loc @@ -592,7 +566,8 @@ addInst :: DynFlags -> InstEnv -> DFunId -> TcM InstEnv addInst dflags home_ie dfun = do { -- Load imported instances, so that we report -- duplicates correctly - pkg_ie <- loadImportedInsts cls tys + let (tvs, _, cls, tys) = tcSplitDFunTy (idType dfun) + ; pkg_ie <- loadImportedInsts cls tys -- Check functional dependencies ; case checkFunDeps (pkg_ie, home_ie) dfun of @@ -600,9 +575,13 @@ addInst dflags home_ie dfun Nothing -> return () -- Check for duplicate instance decls - ; let { (matches, _) = lookupInstEnv dflags (pkg_ie, home_ie) cls tys + -- We instantiate the dfun type because the instance lookup + -- requires nice fresh types in the thing to be looked up + ; (tvs', _, tenv) <- tcInstTyVars tvs + ; let { tys' = substTys tenv tys + ; (matches, _) = lookupInstEnv dflags (pkg_ie, home_ie) cls tys' ; dup_dfuns = [dup_dfun | (_, (_, dup_tys, dup_dfun)) <- matches, - isJust (matchTys (mkVarSet tvs) tys dup_tys)] } + isJust (matchTys (mkVarSet tvs) tys' dup_tys)] } -- Find memebers of the match list which -- dfun itself matches. If the match is 2-way, it's a duplicate ; case dup_dfuns of @@ -611,8 +590,7 @@ addInst dflags home_ie dfun -- OK, now extend the envt ; return (extendInstEnv home_ie dfun) } - where - (tvs, _, cls, tys) = tcSplitDFunTy (idType dfun) + traceDFuns dfuns = traceTc (text "Adding instances:" <+> vcat (map pp dfuns)) @@ -629,7 +607,7 @@ dupInstErr dfun dup_dfun 2 (pprDFuns [dfun, dup_dfun])) addDictLoc dfun thing_inside - = addSrcSpan (mkSrcSpan loc loc) thing_inside + = setSrcSpan (mkSrcSpan loc loc) thing_inside where loc = getSrcLoc dfun \end{code} @@ -717,7 +695,13 @@ lookupInst (Dict _ _ _) = returnM NoInstance ----------------- instantiate_dfun tenv dfun_id pred loc - = traceTc (text "lookupInst success" <+> + = -- tenv is a substitution that instantiates the dfun_id + -- to match the requested result type. However, the dfun + -- might have some tyvars that only appear in arguments + -- dfun :: forall a b. C a b, Ord b => D [a] + -- We instantiate b to a flexi type variable -- it'll presumably + -- become fixed later via functional dependencies + traceTc (text "lookupInst success" <+> vcat [text "dict" <+> ppr pred, text "witness" <+> ppr dfun_id <+> ppr (idType dfun_id) ]) `thenM_` -- Record that this dfun is needed @@ -733,17 +717,17 @@ instantiate_dfun tenv dfun_id pred loc (topIdLvl dfun_id) use_stage `thenM_` let (tyvars, rho) = tcSplitForAllTys (idType dfun_id) - mk_ty_arg tv = case lookupSubstEnv tenv tv of - Just (DoneTy ty) -> returnM ty - Nothing -> tcInstTyVar VanillaTv tv `thenM` \ tc_tv -> - returnM (mkTyVarTy tc_tv) + mk_ty_arg tv = case lookupVarEnv tenv tv of + Just ty -> returnM ty + Nothing -> tcInstTyVar tv `thenM` \ tc_tv -> + returnM (mkTyVarTy tc_tv) in mappM mk_ty_arg tyvars `thenM` \ ty_args -> let - dfun_rho = substTy (mkTopTyVarSubst tyvars ty_args) rho + dfun_rho = substTy (zipTopTvSubst tyvars ty_args) rho -- Since the tyvars are freshly made, -- they cannot possibly be captured by - -- any existing for-alls. Hence mkTopTyVarSubst + -- any existing for-alls. Hence zipTopTyVarSubst (theta, _) = tcSplitPhiTy dfun_rho ty_app = mkHsTyApp (L (instLocSrcSpan loc) (HsVar dfun_id)) ty_args in diff --git a/ghc/compiler/typecheck/TcArrows.lhs b/ghc/compiler/typecheck/TcArrows.lhs index 8ea84ed86c..2ddab4eeb9 100644 --- a/ghc/compiler/typecheck/TcArrows.lhs +++ b/ghc/compiler/typecheck/TcArrows.lhs @@ -8,7 +8,7 @@ module TcArrows ( tcProc ) where #include "HsVersions.h" -import {-# SOURCE #-} TcExpr( tcCheckRho ) +import {-# SOURCE #-} TcExpr( tcCheckRho, tcInferRho ) import HsSyn import TcHsSyn ( mkHsLet ) @@ -17,8 +17,9 @@ import TcMatches ( TcStmtCtxt(..), tcMatchPats, matchCtxt, tcStmts, TcMatchCtxt(..), tcMatchesCase ) import TcType ( TcType, TcTauType, TcRhoType, mkFunTys, mkTyConApp, - mkTyVarTy, mkAppTys, tcSplitTyConApp_maybe, tcEqType ) -import TcMType ( newTyVarTy, newTyVarTys, newSigTyVar, zonkTcType ) + mkTyVarTy, mkAppTys, tcSplitTyConApp_maybe, tcEqType, + SkolemInfo(..) ) +import TcMType ( newTyFlexiVarTy, newTyFlexiVarTys, tcSkolTyVar, zonkTcType ) import TcBinds ( tcBindsAndThen ) import TcSimplify ( tcSimplifyCheck ) import TcUnify ( Expected(..), checkSigTyVarsWrt, zapExpectedTo ) @@ -27,6 +28,7 @@ import Inst ( tcSyntaxName ) import Name ( Name ) import TysWiredIn ( boolTy, pairTyCon ) import VarSet +import TysPrim ( alphaTyVar ) import Type ( Kind, mkArrowKinds, liftedTypeKind, openTypeKind, tyVarsOfTypes ) import SrcLoc ( Located(..) ) @@ -47,16 +49,20 @@ tcProc :: InPat Name -> LHsCmdTop Name -- proc pat -> expr -> TcM (OutPat TcId, LHsCmdTop TcId) tcProc pat cmd exp_ty - = do { arr_ty <- newTyVarTy arrowTyConKind - ; [arg_ty, res_ty] <- newTyVarTys 2 liftedTypeKind +-- gaw 2004 FIX? + = do { arr_ty <- newTyFlexiVarTy arrowTyConKind + ; [arg_ty, res_ty] <- newTyFlexiVarTys 2 liftedTypeKind ; zapExpectedTo exp_ty (mkAppTys arr_ty [arg_ty,res_ty]) ; let cmd_env = CmdEnv { cmd_arr = arr_ty } - ; ([pat'], cmd', ex_binds) <- incProcLevel $ - tcMatchPats [(pat, Check arg_ty)] (Check res_ty) $ - tcCmdTop cmd_env cmd ([], res_ty) - - ; return (pat', glueBindsOnCmd ex_binds cmd') } + ; ([pat'], cmd') <- incProcLevel $ + tcMatchPats [pat] [Check arg_ty] (Check res_ty) $ + tcCmdTop cmd_env cmd ([], res_ty) + -- The False says don't do GADT type refinement + -- This is a conservative choice, but I'm not sure of the consequences + -- of type refinement in the arrow world! + + ; return (pat', cmd') } \end{code} @@ -83,7 +89,7 @@ tcCmdTop :: CmdEnv -> TcM (LHsCmdTop TcId) tcCmdTop env (L loc (HsCmdTop cmd _ _ names)) (cmd_stk, res_ty) - = addSrcSpan loc $ + = setSrcSpan loc $ do { cmd' <- tcCmd env cmd (cmd_stk, res_ty) ; names' <- mapM (tcSyntaxName ProcOrigin (cmd_arr env)) names ; return (L loc $ HsCmdTop cmd' cmd_stk res_ty names') } @@ -93,7 +99,7 @@ tcCmdTop env (L loc (HsCmdTop cmd _ _ names)) (cmd_stk, res_ty) tcCmd :: CmdEnv -> LHsExpr Name -> (CmdStack, TcTauType) -> TcM (LHsExpr TcId) -- The main recursive function tcCmd env (L loc expr) res_ty - = addSrcSpan loc $ do + = setSrcSpan loc $ do { expr' <- tc_cmd env expr res_ty ; return (L loc expr') } @@ -103,18 +109,17 @@ tc_cmd env (HsPar cmd) res_ty tc_cmd env (HsLet binds (L body_loc body)) res_ty = tcBindsAndThen glue binds $ - addSrcSpan body_loc $ + setSrcSpan body_loc $ tc_cmd env body res_ty where glue binds expr = HsLet [binds] (L body_loc expr) tc_cmd env in_cmd@(HsCase scrut matches) (stk, res_ty) = addErrCtxt (cmdCtxt in_cmd) $ - tcMatchesCase match_ctxt matches (Check res_ty) - `thenM` \ (scrut_ty, matches') -> addErrCtxt (caseScrutCtxt scrut) ( - tcCheckRho scrut scrut_ty - ) `thenM` \ scrut' -> + tcInferRho scrut + ) `thenM` \ (scrut', scrut_ty) -> + tcMatchesCase match_ctxt scrut_ty matches (Check res_ty) `thenM` \ matches' -> returnM (HsCase scrut' matches') where match_ctxt = MC { mc_what = CaseAlt, @@ -134,7 +139,7 @@ tc_cmd env (HsIf pred b1 b2) res_ty tc_cmd env cmd@(HsArrApp fun arg _ ho_app lr) (cmd_stk, res_ty) = addErrCtxt (cmdCtxt cmd) $ - do { arg_ty <- newTyVarTy openTypeKind + do { arg_ty <- newTyFlexiVarTy openTypeKind ; let fun_ty = mkCmdArrTy env (foldl mkPairTy arg_ty cmd_stk) res_ty ; fun' <- pop_arrow_binders (tcCheckRho fun fun_ty) @@ -156,7 +161,8 @@ tc_cmd env cmd@(HsArrApp fun arg _ ho_app lr) (cmd_stk, res_ty) tc_cmd env cmd@(HsApp fun arg) (cmd_stk, res_ty) = addErrCtxt (cmdCtxt cmd) $ - do { arg_ty <- newTyVarTy openTypeKind +-- gaw 2004 FIX? + do { arg_ty <- newTyFlexiVarTy openTypeKind ; fun' <- tcCmd env fun (arg_ty:cmd_stk, res_ty) @@ -167,20 +173,22 @@ tc_cmd env cmd@(HsApp fun arg) (cmd_stk, res_ty) ------------------------------------------- -- Lambda -tc_cmd env cmd@(HsLam (L mtch_loc match@(Match pats maybe_rhs_sig grhss))) (cmd_stk, res_ty) +-- gaw 2004 +tc_cmd env cmd@(HsLam (MatchGroup [L mtch_loc (match@(Match pats maybe_rhs_sig grhss))] _)) + (cmd_stk, res_ty) = addErrCtxt (matchCtxt match_ctxt match) $ do { -- Check the cmd stack is big enough ; checkTc (lengthAtLeast cmd_stk n_pats) (kappaUnderflow cmd) - ; let pats_w_tys = zip pats (map Check cmd_stk) -- Check the patterns, and the GRHSs inside - ; (pats', grhss', ex_binds) <- addSrcSpan mtch_loc $ - tcMatchPats pats_w_tys (Check res_ty) $ - tc_grhss grhss + ; (pats', grhss') <- setSrcSpan mtch_loc $ + tcMatchPats pats (map Check cmd_stk) (Check res_ty) $ + tc_grhss grhss - ; return (HsLam (L mtch_loc (Match pats' Nothing (glueBindsOnGRHSs ex_binds grhss')))) + ; let match' = L mtch_loc (Match pats' Nothing grhss') + ; return (HsLam (MatchGroup [match'] res_ty)) } where @@ -188,13 +196,13 @@ tc_cmd env cmd@(HsLam (L mtch_loc match@(Match pats maybe_rhs_sig grhss))) (cmd_ stk' = drop n_pats cmd_stk match_ctxt = LambdaExpr -- Maybe KappaExpr? - tc_grhss (GRHSs grhss binds _) + tc_grhss (GRHSs grhss binds) = tcBindsAndThen glueBindsOnGRHSs binds $ do { grhss' <- mappM (wrapLocM tc_grhs) grhss - ; return (GRHSs grhss' [] res_ty) } + ; return (GRHSs grhss' []) } stmt_ctxt = SC { sc_what = PatGuard match_ctxt, - sc_rhs = tcCheckRho, + sc_rhs = tcInferRho, sc_body = \ body -> tcCmd env body (stk', res_ty), sc_ty = res_ty } -- ToDo: Is this right? tc_grhs (GRHS guarded) @@ -216,8 +224,10 @@ tc_cmd env cmd@(HsDo do_or_lc stmts _ ty) (cmd_stk, res_ty) sc_body = tc_ret, sc_ty = res_ty } - tc_rhs rhs ty = tcCmd env rhs ([], ty) - tc_ret body = tcCmd env body ([], res_ty) + tc_rhs rhs = do { ty <- newTyFlexiVarTy liftedTypeKind + ; rhs' <- tcCmd env rhs ([], ty) + ; return (rhs', ty) } + tc_ret body = tcCmd env body ([], res_ty) ----------------------------------------------------------------- @@ -233,8 +243,9 @@ tc_cmd env cmd@(HsDo do_or_lc stmts _ ty) (cmd_stk, res_ty) tc_cmd env cmd@(HsArrForm expr fixity cmd_args) (cmd_stk, res_ty) = addErrCtxt (cmdCtxt cmd) $ do { cmds_w_tys <- zipWithM new_cmd_ty cmd_args [1..] - ; w_tv <- newSigTyVar liftedTypeKind - ; let w_ty = mkTyVarTy w_tv + ; span <- getSrcSpanM + ; w_tv <- tcSkolTyVar (ArrowSkol span) alphaTyVar + ; let w_ty = mkTyVarTy w_tv -- Just a convenient starting point -- a ((w,t1) .. tn) t ; let e_res_ty = mkCmdArrTy env (foldl mkPairTy w_ty cmd_stk) res_ty @@ -250,14 +261,13 @@ tc_cmd env cmd@(HsArrForm expr fixity cmd_args) (cmd_stk, res_ty) -- Check that the polymorphic variable hasn't been unified with anything -- and is not free in res_ty or the cmd_stk (i.e. t, t1..tn) - ; [w_tv'] <- checkSigTyVarsWrt (tyVarsOfTypes (res_ty:cmd_stk)) - [w_tv] + ; checkSigTyVarsWrt (tyVarsOfTypes (res_ty:cmd_stk)) [w_tv] -- OK, now we are in a position to unscramble -- the s1..sm and check each cmd - ; cmds' <- mapM (tc_cmd w_tv') cmds_w_tys + ; cmds' <- mapM (tc_cmd w_tv) cmds_w_tys - ; returnM (HsArrForm (mkHsTyLam [w_tv'] (mkHsLet inst_binds expr')) fixity cmds') + ; returnM (HsArrForm (mkHsTyLam [w_tv] (mkHsLet inst_binds expr')) fixity cmds') } where -- Make the types @@ -265,11 +275,12 @@ tc_cmd env cmd@(HsArrForm expr fixity cmd_args) (cmd_stk, res_ty) new_cmd_ty :: LHsCmdTop Name -> Int -> TcM (LHsCmdTop Name, Int, TcType, TcType, TcType) new_cmd_ty cmd i - = do { b_ty <- newTyVarTy arrowTyConKind - ; tup_ty <- newTyVarTy liftedTypeKind +-- gaw 2004 FIX? + = do { b_ty <- newTyFlexiVarTy arrowTyConKind + ; tup_ty <- newTyFlexiVarTy liftedTypeKind -- We actually make a type variable for the tuple -- because we don't know how deeply nested it is yet - ; s_ty <- newTyVarTy liftedTypeKind + ; s_ty <- newTyFlexiVarTy liftedTypeKind ; return (cmd, i, b_ty, tup_ty, s_ty) } @@ -317,11 +328,6 @@ tc_cmd env cmd _ \begin{code} -glueBindsOnCmd binds (L loc (HsCmdTop cmd stk res_ty names)) - = L loc (HsCmdTop (L loc (HsLet [binds] cmd)) stk res_ty names) - -- Existential bindings become local bindings in the command - - mkPairTy t1 t2 = mkTyConApp pairTyCon [t1,t2] arrowTyConKind :: Kind -- *->*->* diff --git a/ghc/compiler/typecheck/TcBinds.lhs b/ghc/compiler/typecheck/TcBinds.lhs index c757ffc3e7..f9bcc6db0b 100644 --- a/ghc/compiler/typecheck/TcBinds.lhs +++ b/ghc/compiler/typecheck/TcBinds.lhs @@ -12,38 +12,44 @@ import {-# SOURCE #-} TcMatches ( tcGRHSsPat, tcMatchesFun ) import {-# SOURCE #-} TcExpr ( tcCheckSigma, tcCheckRho ) import CmdLineOpts ( DynFlag(Opt_NoMonomorphismRestriction) ) -import HsSyn ( HsExpr(..), HsBind(..), LHsBind, LHsBinds, Sig(..), +import HsSyn ( HsExpr(..), HsBind(..), LHsBinds, Sig(..), LSig, Match(..), HsBindGroup(..), IPBind(..), - collectSigTysFromHsBinds, collectHsBindBinders, + LPat, GRHSs, MatchGroup(..), emptyLHsBinds, isEmptyLHsBinds, + collectHsBindBinders, collectPatBinders, pprPatBind ) -import TcHsSyn ( TcId, zonkId, mkHsLet ) +import TcHsSyn ( TcId, TcDictBinds, zonkId, mkHsLet ) import TcRnMonad -import Inst ( InstOrigin(..), newDicts, newIPDict, instToId ) -import TcEnv ( tcExtendLocalValEnv, tcExtendLocalValEnv2, newLocalName ) -import TcUnify ( Expected(..), newHole, unifyTauTyLists, checkSigTyVarsWrt, sigCtxt ) +import Inst ( InstOrigin(..), newDictsAtLoc, newIPDict, instToId ) +import TcEnv ( tcExtendIdEnv, tcExtendIdEnv2, newLocalName, tcLookupLocalIds ) +import TcUnify ( Expected(..), tcInfer, checkSigTyVars, sigCtxt ) import TcSimplify ( tcSimplifyInfer, tcSimplifyInferCheck, tcSimplifyRestricted, tcSimplifyToDicts, tcSimplifyIPs ) -import TcHsType ( tcHsSigType, UserTypeCtxt(..), TcSigInfo(..), - tcTySig, maybeSig, tcAddScopedTyVars +import TcHsType ( tcHsSigType, UserTypeCtxt(..), tcAddLetBoundTyVars, + TcSigInfo(..), TcSigFun, mkTcSig, lookupSig ) -import TcPat ( tcPat, tcSubPat, tcMonoPatBndr ) +import TcPat ( tcPat, PatCtxt(..) ) import TcSimplify ( bindInstsOfLocalFuns ) -import TcMType ( newTyVar, newTyVarTy, zonkTcTyVarToTyVar ) -import TcType ( TcTyVar, mkTyVarTy, mkForAllTys, mkFunTys, tyVarsOfType, - mkPredTy, mkForAllTy, isUnLiftedType ) -import Kind ( liftedTypeKind, argTypeKind, isUnliftedTypeKind ) - -import CoreFVs ( idFreeTyVars ) +import TcMType ( newTyFlexiVarTy, tcSkolType, zonkQuantifiedTyVar ) +import TcType ( TcTyVar, SkolemInfo(SigSkol), + TcTauType, TcSigmaType, + TvSubstEnv, mkTvSubst, substTheta, substTy, + mkTyVarTy, mkForAllTys, mkFunTys, tyVarsOfType, + mkForAllTy, isUnLiftedType, tcGetTyVar_maybe, + mkTyVarTys ) +import Unify ( tcMatchPreds ) +import Kind ( argTypeKind, isUnliftedTypeKind ) +import VarEnv ( lookupVarEnv ) +import TysPrim ( alphaTyVar ) import Id ( mkLocalId, mkSpecPragmaId, setInlinePragma ) import Var ( idType, idName ) -import Name ( Name, getSrcLoc ) +import Name ( Name ) import NameSet import Var ( tyVarKind ) import VarSet -import SrcLoc ( Located(..), srcLocSpan, unLoc, noLoc, getLoc ) +import SrcLoc ( Located(..), unLoc, noLoc, getLoc ) import Bag -import Util ( isIn, equalLength ) +import Util ( isIn ) import BasicTypes ( TopLevelFlag(..), RecFlag(..), isNonRec, isRec, isNotTopLevel, isAlwaysActive ) import FiniteMap ( listToFM, lookupFM ) @@ -90,7 +96,7 @@ tcTopBinds :: [HsBindGroup Name] -> TcM (LHsBinds TcId, TcLclEnv) tcTopBinds binds = tc_binds_and_then TopLevel glue binds $ getLclEnv `thenM` \ env -> - returnM (emptyBag, env) + returnM (emptyLHsBinds, env) where -- The top level bindings are flattened into a giant -- implicitly-mutually-recursive MonoBinds @@ -127,13 +133,13 @@ tc_bind_and_then top_lvl combiner (HsIPBinds binds) do_next -- Consider ?x = 4 -- ?y = ?x + 1 tc_ip_bind (IPBind ip expr) - = newTyVarTy argTypeKind `thenM` \ ty -> + = newTyFlexiVarTy argTypeKind `thenM` \ ty -> newIPDict (IPBindOrigin ip) ip ty `thenM` \ (ip', ip_inst) -> tcCheckRho expr ty `thenM` \ expr' -> returnM (ip_inst, (IPBind ip' expr')) tc_bind_and_then top_lvl combiner (HsBindGroup binds sigs is_rec) do_next - | isEmptyBag binds + | isEmptyLHsBinds binds = do_next | otherwise = -- BRING ANY SCOPED TYPE VARIABLES INTO SCOPE @@ -141,7 +147,7 @@ tc_bind_and_then top_lvl combiner (HsBindGroup binds sigs is_rec) do_next -- a) the type signatures in the binding group -- b) the bindings in the group -- c) the scope of the binding group (the "in" part) - tcAddScopedTyVars (collectSigTysFromHsBinds (bagToList binds)) $ + tcAddLetBoundTyVars binds $ case top_lvl of TopLevel -- For the top level don't bother will all this @@ -197,7 +203,7 @@ tc_bind_and_then top_lvl combiner (HsBindGroup binds sigs is_rec) do_next where tc_body poly_ids -- Type check the pragmas and "thing inside" = -- Extend the environment to bind the new polymorphic Ids - tcExtendLocalValEnv poly_ids $ + tcExtendIdEnv poly_ids $ -- Build bindings and IdInfos corresponding to user pragmas tcSpecSigs sigs `thenM` \ prag_binds -> @@ -232,134 +238,107 @@ tcBindWithSigs :: TopLevelFlag -> RecFlag -> TcM (LHsBinds TcId, [TcId]) -tcBindWithSigs top_lvl mbind sigs is_rec - = -- TYPECHECK THE SIGNATURES - recoverM (returnM []) ( - mappM tcTySig [sig | sig@(L _(Sig name _)) <- sigs] - ) `thenM` \ tc_ty_sigs -> +tcBindWithSigs top_lvl mbind sigs is_rec = do + { -- TYPECHECK THE SIGNATURES + tc_ty_sigs <- recoverM (returnM []) $ + tcTySigs [sig | sig@(L _(Sig name _)) <- sigs] + ; let lookup_sig = lookupSig tc_ty_sigs -- SET UP THE MAIN RECOVERY; take advantage of any type sigs - recoverM ( - -- If typechecking the binds fails, then return with each - -- signature-less binder given type (forall a.a), to minimise subsequent - -- error messages - newTyVar liftedTypeKind `thenM` \ alpha_tv -> - let - forall_a_a = mkForAllTy alpha_tv (mkTyVarTy alpha_tv) - binder_names = collectHsBindBinders mbind - poly_ids = map mk_dummy binder_names - mk_dummy name = case maybeSig tc_ty_sigs name of - Just sig -> sig_poly_id sig -- Signature - Nothing -> mkLocalId name forall_a_a -- No signature - in - traceTc (text "tcBindsWithSigs: error recovery" <+> ppr binder_names) `thenM_` - returnM (emptyBag, poly_ids) - ) $ - - -- TYPECHECK THE BINDINGS - traceTc (ptext SLIT("--------------------------------------------------------")) `thenM_` - traceTc (ptext SLIT("Bindings for") <+> ppr (collectHsBindBinders mbind)) `thenM_` - getLIE (tcMonoBinds mbind tc_ty_sigs is_rec) `thenM` \ ((mbind', bndr_names_w_ids), lie_req) -> - let - (binder_names, mono_ids) = unzip (bagToList bndr_names_w_ids) - tau_tvs = foldr (unionVarSet . tyVarsOfType . idType) emptyVarSet mono_ids - in + ; recoverM (recoveryCode mbind lookup_sig) $ do + + { traceTc (ptext SLIT("--------------------------------------------------------")) + ; traceTc (ptext SLIT("Bindings for") <+> ppr (collectHsBindBinders mbind)) + + -- TYPECHECK THE BINDINGS + ; ((mbind', mono_bind_infos), lie_req) + <- getLIE (tcMonoBinds mbind lookup_sig is_rec) -- GENERALISE - -- (it seems a bit crude to have to do getLIE twice, - -- but I can't see a better way just now) - addSrcSpan (getLoc (head (bagToList mbind))) $ - -- TODO: location a bit awkward, but the mbinds have been - -- dependency analysed and may no longer be adjacent - - addErrCtxt (genCtxt binder_names) $ - getLIE (generalise binder_names mbind tau_tvs lie_req tc_ty_sigs) - `thenM` \ ((tc_tyvars_to_gen, dict_binds, dict_ids), lie_free) -> - - - -- ZONK THE GENERALISED TYPE VARIABLES TO REAL TyVars - -- This commits any unbound kind variables to boxed kind, by unification - -- It's important that the final quanfified type variables - -- are fully zonked, *including boxity*, because they'll be - -- included in the forall types of the polymorphic Ids. - -- At calls of these Ids we'll instantiate fresh type variables from - -- them, and we use their boxity then. - mappM zonkTcTyVarToTyVar tc_tyvars_to_gen `thenM` \ real_tyvars_to_gen -> - - -- ZONK THE Ids - -- It's important that the dict Ids are zonked, including the boxity set - -- in the previous step, because they are later used to form the type of - -- the polymorphic thing, and forall-types must be zonked so far as - -- their bound variables are concerned - mappM zonkId dict_ids `thenM` \ zonked_dict_ids -> - mappM zonkId mono_ids `thenM` \ zonked_mono_ids -> + ; is_unres <- isUnRestrictedGroup mbind tc_ty_sigs + ; (tyvars_to_gen, dict_binds, dict_ids) + <- setSrcSpan (getLoc (head (bagToList mbind))) $ + -- TODO: location a bit awkward, but the mbinds have been + -- dependency analysed and may no longer be adjacent + addErrCtxt (genCtxt (bndrNames mono_bind_infos)) $ + generalise is_unres mono_bind_infos tc_ty_sigs lie_req + + -- FINALISE THE QUANTIFIED TYPE VARIABLES + -- The quantified type variables often include meta type variables + -- we want to freeze them into ordinary type variables, and + -- default their kind (e.g. from OpenTypeKind to TypeKind) + ; tyvars_to_gen' <- mappM zonkQuantifiedTyVar tyvars_to_gen -- BUILD THE POLYMORPHIC RESULT IDs - let - exports = zipWith mk_export binder_names zonked_mono_ids + ; let + exports = map mk_export mono_bind_infos poly_ids = [poly_id | (_, poly_id, _) <- exports] - dict_tys = map idType zonked_dict_ids + dict_tys = map idType dict_ids - inlines = mkNameSet [ name - | L _ (InlineSig True (L _ name) _) <- sigs] + inlines = mkNameSet [ name + | L _ (InlineSig True (L _ name) _) <- sigs] -- Any INLINE sig (regardless of phase control) -- makes the RHS look small - inline_phases = listToFM [ (name, phase) | L _ (InlineSig _ (L _ name) phase) <- sigs, not (isAlwaysActive phase)] -- Set the IdInfo field to control the inline phase -- AlwaysActive is the default, so don't bother with them + add_inlines id = attachInlinePhase inline_phases id - mk_export binder_name zonked_mono_id - = (tyvars, - attachInlinePhase inline_phases poly_id, - zonked_mono_id) + mk_export (binder_name, mb_sig, mono_id) + = case mb_sig of + Just sig -> (sig_tvs sig, add_inlines (sig_id sig), mono_id) + Nothing -> (tyvars_to_gen', add_inlines new_poly_id, mono_id) where - (tyvars, poly_id) = - case maybeSig tc_ty_sigs binder_name of - Just sig -> (sig_tvs sig, sig_poly_id sig) - Nothing -> (real_tyvars_to_gen, new_poly_id) - new_poly_id = mkLocalId binder_name poly_ty - poly_ty = mkForAllTys real_tyvars_to_gen + poly_ty = mkForAllTys tyvars_to_gen' $ mkFunTys dict_tys - $ idType zonked_mono_id - -- It's important to build a fully-zonked poly_ty, because - -- we'll slurp out its free type variables when extending the - -- local environment (tcExtendLocalValEnv); if it's not zonked - -- it appears to have free tyvars that aren't actually free - -- at all. - in + $ idType mono_id - traceTc (text "binding:" <+> ppr ((zonked_dict_ids, dict_binds), - exports, map idType poly_ids)) `thenM_` + -- ZONK THE poly_ids, because they are used to extend the type + -- environment; see the invariant on TcEnv.tcExtendIdEnv + ; zonked_poly_ids <- mappM zonkId poly_ids + + ; traceTc (text "binding:" <+> ppr ((dict_ids, dict_binds), + exports, map idType zonked_poly_ids)) -- Check for an unlifted, non-overloaded group -- In that case we must make extra checks - if any (isUnLiftedType . idType) zonked_mono_ids && null zonked_dict_ids + ; if any (isUnLiftedType . idType) zonked_poly_ids then -- Some bindings are unlifted - checkUnliftedBinds top_lvl is_rec real_tyvars_to_gen mbind `thenM_` - - extendLIEs lie_req `thenM_` - returnM ( - unitBag $ noLoc $ - AbsBinds [] [] exports inlines mbind', - -- Do not generate even any x=y bindings - poly_ids - ) + do { checkUnliftedBinds top_lvl is_rec tyvars_to_gen' mbind + ; return ( + unitBag $ noLoc $ + AbsBinds [] [] exports inlines mbind', + -- Do not generate even any x=y bindings + zonked_poly_ids )} else -- The normal case - extendLIEs lie_free `thenM_` - returnM ( + return ( unitBag $ noLoc $ - AbsBinds real_tyvars_to_gen - zonked_dict_ids + AbsBinds tyvars_to_gen' + dict_ids exports inlines (dict_binds `unionBags` mbind'), - poly_ids + zonked_poly_ids ) + } } + +-- If typechecking the binds fails, then return with each +-- signature-less binder given type (forall a.a), to minimise +-- subsequent error messages +recoveryCode mbind lookup_sig + = do { traceTc (text "tcBindsWithSigs: error recovery" <+> ppr binder_names) + ; return (emptyLHsBinds, poly_ids) } + where + forall_a_a = mkForAllTy alphaTyVar (mkTyVarTy alphaTyVar) + binder_names = collectHsBindBinders mbind + poly_ids = map mk_dummy binder_names + mk_dummy name = case lookup_sig name of + Just sig -> sig_id sig -- Signature + Nothing -> mkLocalId name forall_a_a -- No signature attachInlinePhase inline_phases bndr = case lookupFM inline_phases (idName bndr) of @@ -372,8 +351,8 @@ attachInlinePhase inline_phases bndr -- c) non-polymorphic -- d) not a multiple-binding group (more or less implied by (a)) -checkUnliftedBinds top_lvl is_rec real_tyvars_to_gen mbind - = ASSERT( not (any (isUnliftedTypeKind . tyVarKind) real_tyvars_to_gen) ) +checkUnliftedBinds top_lvl is_rec tyvars_to_gen mbind + = ASSERT( not (any (isUnliftedTypeKind . tyVarKind) tyvars_to_gen) ) -- The instCantBeGeneralised stuff in tcSimplify should have -- already raised an error if we're trying to generalise an -- unboxed tyvar (NB: unboxed tyvars are always introduced @@ -387,7 +366,7 @@ checkUnliftedBinds top_lvl is_rec real_tyvars_to_gen mbind (unliftedBindErr "Recursive" mbind) `thenM_` checkTc (isSingletonBag mbind) (unliftedBindErr "Multiple" mbind) `thenM_` - checkTc (null real_tyvars_to_gen) + checkTc (null tyvars_to_gen) (unliftedBindErr "Polymorphic" mbind) \end{code} @@ -450,87 +429,236 @@ is doing. %************************************************************************ %* * -\subsection{getTyVarsToGen} +\subsection{tcMonoBind} %* * %************************************************************************ +@tcMonoBinds@ deals with a single @MonoBind@. +The signatures have been dealt with already. + \begin{code} -generalise binder_names mbind tau_tvs lie_req sigs = +tcMonoBinds :: LHsBinds Name + -> TcSigFun -> RecFlag + -> TcM (LHsBinds TcId, [MonoBindInfo]) + +type MonoBindInfo = (Name, Maybe TcSigInfo, TcId) + -- Type signature (if any), and + -- the monomorphic bound things + +bndrNames :: [MonoBindInfo] -> [Name] +bndrNames mbi = [n | (n,_,_) <- mbi] + +getMonoType :: MonoBindInfo -> TcTauType +getMonoType (_,_,mono_id) = idType mono_id + +tcMonoBinds binds lookup_sig is_rec + = do { tc_binds <- mapBagM (wrapLocM (tcLhs lookup_sig)) binds + ; let mono_info = getMonoBindInfo tc_binds + ; binds' <- tcExtendIdEnv2 (rhsEnvExtension mono_info) $ + mapBagM (wrapLocM tcRhs) tc_binds + ; return (binds', mono_info) } + +------------------------ +-- tcLhs typechecks the LHS of the bindings, to construct the environment in which +-- we typecheck the RHSs. Basically what we are doing is this: for each binder: +-- if there's a signature for it, use the instantiated signature type +-- otherwise invent a type variable +-- You see that quite directly in the FunBind case. +-- +-- But there's a complication for pattern bindings: +-- data T = MkT (forall a. a->a) +-- MkT f = e +-- Here we can guess a type variable for the entire LHS (which will be refined to T) +-- but we want to get (f::forall a. a->a) as the RHS environment. +-- The simplest way to do this is to typecheck the pattern, and then look up the +-- bound mono-ids. Then we want to retain the typechecked pattern to avoid re-doing +-- it; hence the TcMonoBind data type in which the LHS is done but the RHS isn't + +data TcMonoBind -- Half completed; LHS done, RHS not done + = TcFunBind MonoBindInfo (Located TcId) Bool (MatchGroup Name) + | TcPatBind [MonoBindInfo] (LPat TcId) (GRHSs Name) TcSigmaType + +tcLhs :: TcSigFun -> HsBind Name -> TcM TcMonoBind +tcLhs lookup_sig (FunBind (L nm_loc name) inf matches) + = do { let mb_sig = lookup_sig name + ; mono_name <- newLocalName name + ; mono_ty <- mk_mono_ty mb_sig + ; let mono_id = mkLocalId mono_name mono_ty + ; return (TcFunBind (name, mb_sig, mono_id) (L nm_loc mono_id) inf matches) } + where + mk_mono_ty (Just sig) = return (sig_tau sig) + mk_mono_ty Nothing = newTyFlexiVarTy argTypeKind - -- check for -fno-monomorphism-restriction - doptM Opt_NoMonomorphismRestriction `thenM` \ no_MR -> - let is_unrestricted | no_MR = True - | otherwise = isUnRestrictedGroup tysig_names mbind - in +tcLhs lookup_sig bind@(PatBind pat grhss _) + = do { let tc_pat exp_ty = tcPat (LetPat lookup_sig) pat exp_ty lookup_infos + ; ((pat', ex_tvs, infos), pat_ty) + <- addErrCtxt (patMonoBindsCtxt pat grhss) + (tcInfer tc_pat) + + -- Don't know how to deal with pattern-bound existentials yet + ; checkTc (null ex_tvs) (existentialExplode bind) - if not is_unrestricted then -- RESTRICTED CASE - -- Check signature contexts are empty - checkTc (all is_mono_sig sigs) - (restrictedBindCtxtErr binder_names) `thenM_` + ; return (TcPatBind infos pat' grhss pat_ty) } + where + names = collectPatBinders pat + + -- After typechecking the pattern, look up the binder + -- names, which the pattern has brought into scope. + lookup_infos :: TcM [MonoBindInfo] + lookup_infos = do { mono_ids <- tcLookupLocalIds names + ; return [ (name, lookup_sig name, mono_id) + | (name, mono_id) <- names `zip` mono_ids] } + +------------------- +tcRhs :: TcMonoBind -> TcM (HsBind TcId) +tcRhs (TcFunBind _ fun'@(L _ mono_id) inf matches) + = do { matches' <- tcMatchesFun (idName mono_id) matches + (Check (idType mono_id)) + ; return (FunBind fun' inf matches') } + +tcRhs bind@(TcPatBind _ pat' grhss pat_ty) + = do { grhss' <- addErrCtxt (patMonoBindsCtxt pat' grhss) $ + tcGRHSsPat grhss (Check pat_ty) + ; return (PatBind pat' grhss' pat_ty) } + + +--------------------- +getMonoBindInfo :: Bag (Located TcMonoBind) -> [MonoBindInfo] +getMonoBindInfo tc_binds + = foldrBag (get_info . unLoc) [] tc_binds + where + get_info (TcFunBind info _ _ _) rest = info : rest + get_info (TcPatBind infos _ _ _) rest = infos ++ rest + +--------------------- +rhsEnvExtension :: [MonoBindInfo] -> [(Name, TcId)] +-- Environment for RHS of definitions: use type sig if there is one +rhsEnvExtension mono_info + = map mk mono_info + where + mk (name, Just sig, _) = (name, sig_id sig) + mk (name, Nothing, mono_id) = (name, mono_id) +\end{code} + + +%************************************************************************ +%* * +\subsection{getTyVarsToGen} +%* * +%************************************************************************ + +\begin{code} +tcTySigs :: [LSig Name] -> TcM [TcSigInfo] +-- The trick here is that all the signatures should have the same +-- context, and we want to share type variables for that context, so that +-- all the right hand sides agree a common vocabulary for their type +-- constraints +tcTySigs [] = return [] +tcTySigs (L span (Sig (L _ name) ty) : sigs) + = do { -- Typecheck the first signature + ; sigma1 <- setSrcSpan span $ + tcHsSigType (FunSigCtxt name) ty + ; let id1 = mkLocalId name sigma1 + ; tc_sig1 <- mkTcSig id1 + + ; tc_sigs <- mapM (tcTySig tc_sig1) sigs + ; return (tc_sig1 : tc_sigs) } + +tcTySig sig1 (L span (Sig (L _ name) ty)) + = setSrcSpan span $ + do { sigma_ty <- tcHsSigType (FunSigCtxt name) ty + ; (tvs, theta, tau) <- tcSkolType rigid_info sigma_ty + ; let poly_id = mkLocalId name sigma_ty + bale_out = failWithTc $ + sigContextsErr (sig_id sig1) name sigma_ty + + -- Try to match the context of this signature with + -- that of the first signature + ; case tcMatchPreds tvs (sig_theta sig1) theta of { + Nothing -> bale_out + ; Just tenv -> do + ; case check_tvs tenv tvs of + Nothing -> bale_out + Just tvs' -> do + + { let subst = mkTvSubst tenv + theta' = substTheta subst theta + tau' = substTy subst tau + ; loc <- getInstLoc (SigOrigin rigid_info) + ; return (TcSigInfo { sig_id = poly_id, sig_tvs = tvs', + sig_theta = theta', sig_tau = tau', + sig_loc = loc }) }}} + where + rigid_info = SigSkol name + + -- Rather tedious check that the type variables + -- have been matched only with another type variable, + -- and that two type variables have not been matched + -- with the same one + -- A return of Nothing indicates that one of the bad + -- things has happened + check_tvs :: TvSubstEnv -> [TcTyVar] -> Maybe [TcTyVar] + check_tvs tenv [] = Just [] + check_tvs tenv (tv:tvs) + | Just ty <- lookupVarEnv tenv tv + = do { tv' <- tcGetTyVar_maybe ty + ; tvs' <- check_tvs tenv tvs + ; if tv' `elem` tvs' + then Nothing + else Just (tv':tvs') } + | otherwise + = do { tvs' <- check_tvs tenv tvs + ; Just (tv:tvs') } +\end{code} + +\begin{code} +generalise :: Bool -> [MonoBindInfo] -> [TcSigInfo] -> [Inst] + -> TcM ([TcTyVar], TcDictBinds, [TcId]) +generalise is_unrestricted mono_infos sigs lie_req + | not is_unrestricted -- RESTRICTED CASE + = -- Check signature contexts are empty + do { checkTc (all is_mono_sig sigs) + (restrictedBindCtxtErr bndr_names) -- Now simplify with exactly that set of tyvars -- We have to squash those Methods - tcSimplifyRestricted doc tau_tvs lie_req `thenM` \ (qtvs, binds) -> + ; (qtvs, binds) <- tcSimplifyRestricted doc tau_tvs lie_req -- Check that signature type variables are OK - checkSigsTyVars qtvs sigs `thenM` \ final_qtvs -> + ; final_qtvs <- checkSigsTyVars qtvs sigs - returnM (final_qtvs, binds, []) + ; return (final_qtvs, binds, []) } - else if null sigs then -- UNRESTRICTED CASE, NO TYPE SIGS - tcSimplifyInfer doc tau_tvs lie_req + | null sigs -- UNRESTRICTED CASE, NO TYPE SIGS + = tcSimplifyInfer doc tau_tvs lie_req + + | otherwise -- UNRESTRICTED CASE, WITH TYPE SIGS + = do { let sig1 = head sigs + ; sig_lie <- newDictsAtLoc (sig_loc sig1) (sig_theta sig1) + ; let -- The "sig_avails" is the stuff available. We get that from + -- the context of the type signature, BUT ALSO the lie_avail + -- so that polymorphic recursion works right (see comments at end of fn) + local_meths = [mkMethInst sig mono_id | (_, Just sig, mono_id) <- mono_infos] + sig_avails = sig_lie ++ local_meths - else -- UNRESTRICTED CASE, WITH TYPE SIGS - -- CHECKING CASE: Unrestricted group, there are type signatures - -- Check signature contexts are identical - checkSigsCtxts sigs `thenM` \ (sig_avails, sig_dicts) -> - -- Check that the needed dicts can be -- expressed in terms of the signature ones - tcSimplifyInferCheck doc tau_tvs sig_avails lie_req `thenM` \ (forall_tvs, dict_binds) -> + ; (forall_tvs, dict_binds) <- tcSimplifyInferCheck doc tau_tvs sig_avails lie_req -- Check that signature type variables are OK - checkSigsTyVars forall_tvs sigs `thenM` \ final_qtvs -> + ; final_qtvs <- checkSigsTyVars forall_tvs sigs - returnM (final_qtvs, dict_binds, sig_dicts) + ; returnM (final_qtvs, dict_binds, map instToId sig_lie) } where - tysig_names = map (idName . sig_poly_id) sigs + bndr_names = bndrNames mono_infos + tau_tvs = foldr (unionVarSet . tyVarsOfType . getMonoType) emptyVarSet mono_infos is_mono_sig sig = null (sig_theta sig) + doc = ptext SLIT("type signature(s) for") <+> pprBinders bndr_names - doc = ptext SLIT("type signature(s) for") <+> pprBinders binder_names - ------------------------ - -- CHECK THAT ALL THE SIGNATURE CONTEXTS ARE UNIFIABLE - -- The type signatures on a mutually-recursive group of definitions - -- must all have the same context (or none). - -- - -- We unify them because, with polymorphic recursion, their types - -- might not otherwise be related. This is a rather subtle issue. - -- ToDo: amplify -checkSigsCtxts sigs@(TySigInfo { sig_poly_id = id1, sig_tvs = sig_tvs, sig_theta = theta1, sig_loc = span} - : other_sigs) - = addSrcSpan span $ - mappM_ check_one other_sigs `thenM_` - if null theta1 then - returnM ([], []) -- Non-overloaded type signatures - else - newDicts SignatureOrigin theta1 `thenM` \ sig_dicts -> - let - -- The "sig_avails" is the stuff available. We get that from - -- the context of the type signature, BUT ALSO the lie_avail - -- so that polymorphic recursion works right (see comments at end of fn) - sig_avails = sig_dicts ++ sig_meths - in - returnM (sig_avails, map instToId sig_dicts) - where - sig1_dict_tys = map mkPredTy theta1 - sig_meths = concatMap sig_insts sigs - - check_one (TySigInfo {sig_poly_id = id, sig_theta = theta}) - = addErrCtxt (sigContextsCtxt id1 id) $ - checkTc (equalLength theta theta1) sigContextsErr `thenM_` - unifyTauTyLists sig1_dict_tys (map mkPredTy theta) +mkMethInst (TcSigInfo { sig_id = poly_id, sig_tvs = tvs, + sig_theta = theta, sig_tau = tau, sig_loc = loc }) mono_id + = Method mono_id poly_id (mkTyVarTys tvs) theta tau loc checkSigsTyVars :: [TcTyVar] -> [TcSigInfo] -> TcM [TcTyVar] checkSigsTyVars qtvs sigs @@ -550,11 +678,11 @@ checkSigsTyVars qtvs sigs in returnM (varSetElems all_tvs) where - check_one (TySigInfo {sig_poly_id = id, sig_tvs = tvs, sig_theta = theta, sig_tau = tau}) + check_one (TcSigInfo {sig_id = id, sig_tvs = tvs, sig_theta = theta, sig_tau = tau}) = addErrCtxt (ptext SLIT("In the type signature for") <+> quotes (ppr id)) $ addErrCtxtM (sigCtxt id tvs theta tau) $ - checkSigTyVarsWrt (idFreeTyVars id) tvs + do { checkSigTyVars tvs; return tvs } \end{code} @getTyVarsToGen@ decides what type variables to generalise over. @@ -597,17 +725,20 @@ constrained tyvars. We don't use any of the results, except to find which tyvars are constrained. \begin{code} -isUnRestrictedGroup :: [Name] -- Signatures given for these - -> LHsBinds Name - -> Bool -isUnRestrictedGroup sigs binds = all (unrestricted . unLoc) (bagToList binds) +isUnRestrictedGroup :: LHsBinds Name -> [TcSigInfo] -> TcM Bool +isUnRestrictedGroup binds sigs + = do { no_MR <- doptM Opt_NoMonomorphismRestriction + ; return (no_MR || all_unrestricted) } where - unrestricted (PatBind other _) = False - unrestricted (VarBind v _) = v `is_elem` sigs - unrestricted (FunBind v _ matches) = unrestricted_match matches - || unLoc v `is_elem` sigs + all_unrestricted = all (unrestricted . unLoc) (bagToList binds) + tysig_names = map (idName . sig_id) sigs + + unrestricted (PatBind other _ _) = False + unrestricted (VarBind v _) = v `is_elem` tysig_names + unrestricted (FunBind v _ matches) = unrestricted_match matches + || unLoc v `is_elem` tysig_names - unrestricted_match (L _ (Match [] _ _) : _) = False + unrestricted_match (MatchGroup (L _ (Match [] _ _) : _) _) = False -- No args => like a pattern binding unrestricted_match other = True -- Some args => a function binding @@ -618,153 +749,6 @@ is_elem v vs = isIn "isUnResMono" v vs %************************************************************************ %* * -\subsection{tcMonoBind} -%* * -%************************************************************************ - -@tcMonoBinds@ deals with a single @MonoBind@. -The signatures have been dealt with already. - -\begin{code} -tcMonoBinds :: LHsBinds Name - -> [TcSigInfo] -> RecFlag - -> TcM (LHsBinds TcId, - Bag (Name, -- Bound names - TcId)) -- Corresponding monomorphic bound things - -tcMonoBinds mbinds tc_ty_sigs is_rec - -- Three stages: - -- 1. Check the patterns, building up an environment binding - -- the variables in this group (in the recursive case) - -- 2. Extend the environment - -- 3. Check the RHSs - = mapBagM tc_lbind_pats mbinds `thenM` \ bag_of_pairs -> - let - (complete_it, xve) - = foldrBag combine - (returnM (emptyBag, emptyBag), emptyBag) - bag_of_pairs - combine (complete_it1, xve1) (complete_it2, xve2) - = (complete_it, xve1 `unionBags` xve2) - where - complete_it = complete_it1 `thenM` \ (b1, bs1) -> - complete_it2 `thenM` \ (b2, bs2) -> - returnM (b1 `consBag` b2, bs1 `unionBags` bs2) - in - tcExtendLocalValEnv2 (bagToList xve) complete_it - where - tc_lbind_pats :: LHsBind Name - -> TcM (TcM (LHsBind TcId, Bag (Name,TcId)), -- Completer - Bag (Name,TcId)) - -- wrapper for tc_bind_pats to deal with the location stuff - tc_lbind_pats (L loc bind) - = addSrcSpan loc $ do - (tc, bag) <- tc_bind_pats bind - return (wrap tc, bag) - where - wrap tc = addSrcSpan loc $ do - (bind, stuff) <- tc - return (L loc bind, stuff) - - - tc_bind_pats :: HsBind Name - -> TcM (TcM (HsBind TcId, Bag (Name,TcId)), -- Completer - Bag (Name,TcId)) - tc_bind_pats (FunBind (L nm_loc name) inf matches) - -- Three cases: - -- a) Type sig supplied - -- b) No type sig and recursive - -- c) No type sig and non-recursive - - | Just sig <- maybeSig tc_ty_sigs name - = let -- (a) There is a type signature - -- Use it for the environment extension, and check - -- the RHS has the appropriate type (with outer for-alls stripped off) - mono_id = sig_mono_id sig - mono_ty = idType mono_id - complete_it = tcMatchesFun name matches (Check mono_ty) `thenM` \ matches' -> - returnM (FunBind (L nm_loc mono_id) inf matches', - unitBag (name, mono_id)) - in - returnM (complete_it, if isRec is_rec then unitBag (name, sig_poly_id sig) - else emptyBag) - - | isRec is_rec - = -- (b) No type signature, and recursive - -- So we must use an ordinary H-M type variable - -- which means the variable gets an inferred tau-type - newLocalName name `thenM` \ mono_name -> - newTyVarTy argTypeKind `thenM` \ mono_ty -> - let - mono_id = mkLocalId mono_name mono_ty - complete_it = tcMatchesFun name matches (Check mono_ty) `thenM` \ matches' -> - returnM (FunBind (L nm_loc mono_id) inf matches', - unitBag (name, mono_id)) - in - returnM (complete_it, unitBag (name, mono_id)) - - | otherwise -- (c) No type signature, and non-recursive - = let -- So we can use a 'hole' type to infer a higher-rank type - complete_it - = newHole `thenM` \ hole -> - tcMatchesFun name matches (Infer hole) `thenM` \ matches' -> - readMutVar hole `thenM` \ fun_ty -> - newLocalName name `thenM` \ mono_name -> - let - mono_id = mkLocalId mono_name fun_ty - in - returnM (FunBind (L nm_loc mono_id) inf matches', - unitBag (name, mono_id)) - in - returnM (complete_it, emptyBag) - - tc_bind_pats bind@(PatBind pat grhss) - = -- Now typecheck the pattern - -- We do now support binding fresh (not-already-in-scope) scoped - -- type variables in the pattern of a pattern binding. - -- For example, this is now legal: - -- (x::a, y::b) = e - -- The type variables are brought into scope in tc_binds_and_then, - -- so we don't have to do anything here. - newHole `thenM` \ hole -> - tcPat tc_pat_bndr pat (Infer hole) `thenM` \ (pat', tvs, ids, lie_avail) -> - readMutVar hole `thenM` \ pat_ty -> - - -- Don't know how to deal with pattern-bound existentials yet - checkTc (isEmptyBag tvs && null lie_avail) - (existentialExplode bind) `thenM_` - - let - complete_it = addErrCtxt (patMonoBindsCtxt bind) $ - tcGRHSsPat grhss (Check pat_ty) `thenM` \ grhss' -> - returnM (PatBind pat' grhss', ids) - in - returnM (complete_it, if isRec is_rec then ids else emptyBag) - - -- tc_pat_bndr is used when dealing with a LHS binder in a pattern. - -- If there was a type sig for that Id, we want to make it much - -- as if that type signature had been on the binder as a SigPatIn. - -- We check for a type signature; if there is one, we use the mono_id - -- from the signature. This is how we make sure the tau part of the - -- signature actually matches the type of the LHS; then tc_bind_pats - -- ensures the LHS and RHS have the same type - - tc_pat_bndr name pat_ty - = case maybeSig tc_ty_sigs name of - Nothing -> newLocalName name `thenM` \ bndr_name -> - tcMonoPatBndr bndr_name pat_ty - - Just sig -> addSrcSpan (srcLocSpan (getSrcLoc name)) $ - -- TODO: location wrong - tcSubPat (idType mono_id) pat_ty `thenM` \ co_fn -> - returnM (co_fn, mono_id) - where - mono_id = sig_mono_id sig -\end{code} - - -%************************************************************************ -%* * \subsection{SPECIALIZE pragmas} %* * %************************************************************************ @@ -808,7 +792,7 @@ a RULE now: tcSpecSigs :: [LSig Name] -> TcM (LHsBinds TcId) tcSpecSigs (L loc (SpecSig (L nm_loc name) poly_ty) : sigs) = -- SPECIALISE f :: forall b. theta => tau = g - addSrcSpan loc $ + setSrcSpan loc $ addErrCtxt (valSpecSigCtxt name poly_ty) $ -- Get and instantiate its alleged specialised type @@ -835,7 +819,7 @@ tcSpecSigs (L loc (SpecSig (L nm_loc name) poly_ty) : sigs) returnM (binds_rest `snocBag` L loc spec_bind) tcSpecSigs (other_sig : sigs) = tcSpecSigs sigs -tcSpecSigs [] = returnM emptyBag +tcSpecSigs [] = returnM emptyLHsBinds \end{code} %************************************************************************ @@ -846,8 +830,10 @@ tcSpecSigs [] = returnM emptyBag \begin{code} -patMonoBindsCtxt bind - = hang (ptext SLIT("In a pattern binding:")) 4 (ppr bind) +-- This one is called on LHS, when pat and grhss are both Name +-- and on RHS, when pat is TcId and grhss is still Name +patMonoBindsCtxt pat grhss + = hang (ptext SLIT("In a pattern binding:")) 4 (pprPatBind pat grhss) ----------------------------------------------- valSpecSigCtxt v ty @@ -855,14 +841,13 @@ valSpecSigCtxt v ty nest 4 (ppr v <+> dcolon <+> ppr ty)] ----------------------------------------------- -sigContextsErr = ptext SLIT("Mismatched contexts") - -sigContextsCtxt s1 s2 - = vcat [ptext SLIT("When matching the contexts of the signatures for"), - nest 2 (vcat [ppr s1 <+> dcolon <+> ppr (idType s1), - ppr s2 <+> dcolon <+> ppr (idType s2)]), +sigContextsErr id1 name ty + = vcat [ptext SLIT("Mis-match between the contexts of the signatures for"), + nest 2 (vcat [ppr id1 <+> dcolon <+> ppr (idType id1), + ppr name <+> dcolon <+> ppr ty]), ptext SLIT("The signature contexts in a mutually recursive group should all be identical")] + ----------------------------------------------- unliftedBindErr flavour mbind = hang (text flavour <+> ptext SLIT("bindings for unlifted types aren't allowed:")) diff --git a/ghc/compiler/typecheck/TcClassDcl.lhs b/ghc/compiler/typecheck/TcClassDcl.lhs index 0c4f500d67..17121754f7 100644 --- a/ghc/compiler/typecheck/TcClassDcl.lhs +++ b/ghc/compiler/typecheck/TcClassDcl.lhs @@ -18,8 +18,8 @@ import RnHsSyn ( maybeGenericMatch, extractHsTyVars ) import RnExpr ( rnLExpr ) import RnEnv ( lookupTopBndrRn, lookupImportedName ) -import Inst ( Inst, InstOrigin(..), instToId, newDicts, newMethod ) -import TcEnv ( tcLookupLocatedClass, tcExtendLocalValEnv2, +import Inst ( Inst, InstOrigin(..), instToId, newDicts, newDictsAtLoc, newMethod ) +import TcEnv ( tcLookupLocatedClass, tcExtendIdEnv2, tcExtendTyVarEnv2, InstInfo(..), pprInstInfoDetails, simpleInstInfoTyCon, simpleInstInfoTy, @@ -29,8 +29,9 @@ import TcBinds ( tcMonoBinds, tcSpecSigs ) import TcHsType ( TcSigInfo(..), mkTcSig, tcHsKindedType, tcHsSigType ) import TcSimplify ( tcSimplifyCheck, bindInstsOfLocalFuns ) import TcUnify ( checkSigTyVars, sigCtxt ) -import TcMType ( tcInstTyVars, UserTypeCtxt( GenPatCtxt ) ) -import TcType ( Type, TyVarDetails(..), TcType, TcThetaType, TcTyVar, +import TcMType ( tcSkolTyVars, UserTypeCtxt( GenPatCtxt ) ) +import TcType ( Type, SkolemInfo(ClsSkol, InstSkol), + TcType, TcThetaType, TcTyVar, mkTyVarTys, mkClassPred, tcSplitSigmaTy, tcSplitFunTys, tcIsTyVarTy, tcSplitTyConApp_maybe, tcSplitForAllTys, tcSplitPhiTy, getClassPredTys_maybe, mkPhiTy, mkTyVarTy @@ -41,7 +42,7 @@ import PrelInfo ( nO_METHOD_BINDING_ERROR_ID ) import Class ( classTyVars, classBigSig, Class, ClassOpItem, DefMeth (..) ) import TyCon ( TyCon, tyConName, tyConHasGenerics ) -import Subst ( substTyWith ) +import Type ( substTyWith ) import MkId ( mkDefaultMethodId, mkDictFunId ) import Id ( Id, idType, idName, mkUserLocal, setInlinePragma ) import Name ( Name, NamedThing(..) ) @@ -132,7 +133,7 @@ checkDefaultBinds clas ops binds = do dm_infos <- mapM (addLocM (checkDefaultBind clas ops)) (bagToList binds) return (mkNameEnv dm_infos) -checkDefaultBind clas ops (FunBind (L _ op) _ matches) +checkDefaultBind clas ops (FunBind (L _ op) _ (MatchGroup matches _)) = do { -- Check that the op is from this class checkTc (op `elem` ops) (badMethodErr clas op) @@ -152,7 +153,7 @@ tcClassSig :: NameEnv Bool -- Info about default methods; -> TcM TcMethInfo tcClassSig dm_env (L loc (Sig (L _ op_name) op_hs_ty)) - = addSrcSpan loc $ do + = setSrcSpan loc $ do { op_ty <- tcHsKindedType op_hs_ty -- Class tyvars already in scope ; let dm = case lookupNameEnv dm_env op_name of Nothing -> NoDefMeth @@ -232,8 +233,8 @@ tcClassDecl2 :: LTyClDecl Name -- The class declaration tcClassDecl2 (L loc (ClassDecl {tcdLName = class_name, tcdSigs = sigs, tcdMeths = default_binds})) - = recoverM (returnM (emptyBag, [])) $ - addSrcSpan loc $ + = recoverM (returnM (emptyLHsBinds, [])) $ + setSrcSpan loc $ tcLookupLocatedClass class_name `thenM` \ clas -> -- We make a separate binding for each default method. @@ -261,43 +262,43 @@ tcClassDecl2 (L loc (ClassDecl {tcdLName = class_name, tcdSigs = sigs, returnM (listToBag defm_binds, concat dm_ids_s) tcDefMeth clas tyvars binds_in prags sel_id - = lookupTopBndrRn (mkDefMethRdrName sel_id) `thenM` \ dm_name -> - tcInstTyVars ClsTv tyvars `thenM` \ (clas_tyvars, inst_tys, _) -> - let - dm_ty = idType sel_id -- Same as dict selector! - theta = [mkClassPred clas inst_tys] - local_dm_id = mkDefaultMethodId dm_name dm_ty - xtve = tyvars `zip` clas_tyvars - origin = ClassDeclOrigin - in - mkMethodBind origin clas inst_tys - binds_in (sel_id, DefMeth) `thenM` \ (_, meth_info) -> - newDicts origin theta `thenM` \ [this_dict] -> - getLIE (tcMethodBind xtve clas_tyvars theta - [this_dict] prags meth_info) `thenM` \ (defm_bind, insts_needed) -> + = do { dm_name <- lookupTopBndrRn (mkDefMethRdrName sel_id) + ; let rigid_info = ClsSkol clas + ; clas_tyvars <- tcSkolTyVars rigid_info tyvars + ; let + inst_tys = mkTyVarTys clas_tyvars + dm_ty = idType sel_id -- Same as dict selector! + theta = [mkClassPred clas inst_tys] + local_dm_id = mkDefaultMethodId dm_name dm_ty + xtve = tyvars `zip` clas_tyvars + origin = SigOrigin rigid_info + + ; (_, meth_info) <- mkMethodBind origin clas inst_tys binds_in (sel_id, DefMeth) + ; [this_dict] <- newDicts origin theta + ; (defm_bind, insts_needed) <- getLIE (tcMethodBind xtve clas_tyvars theta + [this_dict] prags meth_info) - addErrCtxt (defltMethCtxt clas) $ + ; addErrCtxt (defltMethCtxt clas) $ do -- Check the context - tcSimplifyCheck - (ptext SLIT("class") <+> ppr clas) - clas_tyvars - [this_dict] - insts_needed `thenM` \ dict_binds -> + { dict_binds <- tcSimplifyCheck + (ptext SLIT("class") <+> ppr clas) + clas_tyvars + [this_dict] + insts_needed -- Simplification can do unification - checkSigTyVars clas_tyvars `thenM` \ clas_tyvars' -> + ; checkSigTyVars clas_tyvars - let - (_,dm_inst_id,_) = meth_info - full_bind = AbsBinds - clas_tyvars' - [instToId this_dict] - [(clas_tyvars', local_dm_id, dm_inst_id)] - emptyNameSet -- No inlines (yet) - (dict_binds `unionBags` defm_bind) - in - returnM (noLoc full_bind, [local_dm_id]) + ; let + (_,dm_inst_id,_) = meth_info + full_bind = AbsBinds + clas_tyvars + [instToId this_dict] + [(clas_tyvars, local_dm_id, dm_inst_id)] + emptyNameSet -- No inlines (yet) + (dict_binds `unionBags` defm_bind) + ; returnM (noLoc full_bind, [local_dm_id]) }} mkDefMethRdrName :: Id -> RdrName mkDefMethRdrName sel_id = mkDerivedRdrName (idName sel_id) mkDefaultMethodOcc @@ -336,7 +337,7 @@ tcMethodBind tcMethodBind xtve inst_tyvars inst_theta avail_insts prags (sel_id, meth_id, meth_bind) - = recoverM (returnM emptyBag) $ + = recoverM (returnM emptyLHsBinds) $ -- If anything fails, recover returning no bindings. -- This is particularly useful when checking the default-method binding of -- a class decl. If we don't recover, we don't add the default method to @@ -345,12 +346,14 @@ tcMethodBind xtve inst_tyvars inst_theta avail_insts prags -- Check the bindings; first adding inst_tyvars to the envt -- so that we don't quantify over them in nested places mkTcSig meth_id `thenM` \ meth_sig -> - + let lookup_sig name = ASSERT( name == idName meth_id ) + Just meth_sig + in tcExtendTyVarEnv2 xtve ( addErrCtxt (methodCtxt sel_id) $ getLIE $ - tcMonoBinds (unitBag meth_bind) [meth_sig] NonRecursive - ) `thenM` \ ((meth_bind,_), meth_lie) -> + tcMonoBinds (unitBag meth_bind) lookup_sig NonRecursive + ) `thenM` \ ((meth_bind, mono_bind_infos), meth_lie) -> -- Now do context reduction. We simplify wrt both the local tyvars -- and the ones of the class/instance decl, so that there is @@ -360,13 +363,10 @@ tcMethodBind xtve inst_tyvars inst_theta avail_insts prags -- -- We do this for each method independently to localise error messages - let - TySigInfo { sig_poly_id = meth_id, sig_tvs = meth_tvs, - sig_theta = meth_theta, sig_mono_id = local_meth_id } = meth_sig - in addErrCtxtM (sigCtxt sel_id inst_tyvars inst_theta (idType meth_id)) $ - newDicts SignatureOrigin meth_theta `thenM` \ meth_dicts -> + newDictsAtLoc (sig_loc meth_sig) (sig_theta meth_sig) `thenM` \ meth_dicts -> let + meth_tvs = sig_tvs meth_sig all_tyvars = meth_tvs ++ inst_tyvars all_insts = avail_insts ++ meth_dicts in @@ -374,7 +374,7 @@ tcMethodBind xtve inst_tyvars inst_theta avail_insts prags (ptext SLIT("class or instance method") <+> quotes (ppr sel_id)) all_tyvars all_insts meth_lie `thenM` \ lie_binds -> - checkSigTyVars all_tyvars `thenM` \ all_tyvars' -> + checkSigTyVars all_tyvars `thenM_` let sel_name = idName sel_id @@ -393,17 +393,17 @@ tcMethodBind xtve inst_tyvars inst_theta avail_insts prags | otherwise = (meth_id, emptyNameSet) - meth_tvs' = take (length meth_tvs) all_tyvars' - poly_meth_bind = noLoc $ AbsBinds meth_tvs' + [(_,_,local_meth_id)] = mono_bind_infos + poly_meth_bind = noLoc $ AbsBinds meth_tvs (map instToId meth_dicts) - [(meth_tvs', final_meth_id, local_meth_id)] + [(meth_tvs, final_meth_id, local_meth_id)] inlines (lie_binds `unionBags` meth_bind) in -- Deal with specialisation pragmas -- The sel_name is what appears in the pragma - tcExtendLocalValEnv2 [(sel_name, final_meth_id)] ( + tcExtendIdEnv2 [(sel_name, final_meth_id)] ( getLIE (tcSpecSigs spec_prags) `thenM` \ (spec_binds1, prag_lie) -> -- The prag_lie for a SPECIALISE pragma will mention the function itself, @@ -438,7 +438,7 @@ mkMethodBind origin clas inst_tys meth_binds (sel_id, dm_info) mkDefMethRhs origin clas inst_tys sel_id loc dm_info `thenM` \ rhs -> -- Not infix decl returnM (noLoc $ FunBind (noLoc meth_name) False - [mkSimpleMatch [] rhs placeHolderType]) + (mkMatchGroup [mkSimpleMatch [] rhs])) ) `thenM` \ meth_bind -> returnM (mb_inst, (sel_id, meth_id, meth_bind)) @@ -506,7 +506,7 @@ mkDefMethRhs origin clas inst_tys sel_id loc NoDefMeth (omittedMethodWarn sel_id) `thenM_` returnM error_rhs where - error_rhs = noLoc $ HsLam (mkSimpleMatch wild_pats simple_rhs placeHolderType) + error_rhs = noLoc $ HsLam (mkMatchGroup [mkSimpleMatch wild_pats simple_rhs]) simple_rhs = nlHsApp (nlHsVar (getName nO_METHOD_BINDING_ERROR_ID)) (nlHsLit (HsStringPrim (mkFastString (stringToUtf8 error_msg)))) error_msg = showSDoc (hcat [ppr loc, text "|", ppr sel_id ]) @@ -566,8 +566,8 @@ mkDefMethRhs origin clas inst_tys sel_id loc GenDefMeth other -> Nothing other -> Nothing -isInstDecl InstanceDeclOrigin = True -isInstDecl ClassDeclOrigin = False +isInstDecl (SigOrigin (InstSkol _)) = True +isInstDecl (SigOrigin (ClsSkol _)) = False \end{code} @@ -678,10 +678,10 @@ getGenericBinds :: LHsBinds Name -> [(HsType Name, LHsBind Name)] -- them in finite map indexed by the type parameter in the definition. getGenericBinds binds = concat (map getGenericBind (bagToList binds)) -getGenericBind (L loc (FunBind id infixop matches)) +getGenericBind (L loc (FunBind id infixop (MatchGroup matches ty))) = groupWith wrap (mapCatMaybes maybeGenericMatch matches) where - wrap ms = L loc (FunBind id infixop ms) + wrap ms = L loc (FunBind id infixop (MatchGroup ms ty)) getGenericBind _ = [] diff --git a/ghc/compiler/typecheck/TcDefaults.lhs b/ghc/compiler/typecheck/TcDefaults.lhs index 78c92b06e8..6c9de36a3c 100644 --- a/ghc/compiler/typecheck/TcDefaults.lhs +++ b/ghc/compiler/typecheck/TcDefaults.lhs @@ -42,7 +42,7 @@ tcDefaults [L locn (DefaultDecl [])] = returnM (Just []) -- Default declaration specifying no types tcDefaults [L locn (DefaultDecl mono_tys)] - = addSrcSpan locn $ + = setSrcSpan locn $ addErrCtxt defaultDeclCtxt $ tcLookupClass numClassName `thenM` \ num_class -> mappM tc_default_ty mono_tys `thenM` \ tau_tys -> @@ -54,7 +54,7 @@ tcDefaults [L locn (DefaultDecl mono_tys)] returnM (Just tau_tys) tcDefaults decls@(L locn (DefaultDecl _) : _) = - addSrcSpan locn $ + setSrcSpan locn $ failWithTc (dupDefaultDeclErr decls) diff --git a/ghc/compiler/typecheck/TcDeriv.lhs b/ghc/compiler/typecheck/TcDeriv.lhs index 82a6d26332..b74daf34f9 100644 --- a/ghc/compiler/typecheck/TcDeriv.lhs +++ b/ghc/compiler/typecheck/TcDeriv.lhs @@ -29,17 +29,17 @@ import RnEnv ( bindLocalNames ) import HscTypes ( DFunId, FixityEnv ) import Class ( className, classArity, classKey, classTyVars, classSCTheta, Class ) -import Subst ( mkTyVarSubst, substTheta ) +import Type ( zipTvSubst, substTheta ) import ErrUtils ( dumpIfSet_dyn ) import MkId ( mkDictFunId ) -import DataCon ( isNullaryDataCon, isExistentialDataCon, dataConOrigArgTys ) +import DataCon ( isNullarySrcDataCon, isVanillaDataCon, dataConOrigArgTys ) import Maybes ( catMaybes ) import RdrName ( RdrName ) import Name ( Name, getSrcLoc ) import NameSet ( NameSet, emptyNameSet, duDefs ) import Kind ( splitKindFunTys ) import TyCon ( tyConTyVars, tyConDataCons, tyConArity, tyConHasGenerics, - tyConTheta, isProductTyCon, isDataTyCon, newTyConRhs, + tyConStupidTheta, isProductTyCon, isDataTyCon, newTyConRhs, isEnumerationTyCon, isRecursiveTyCon, TyCon ) import TcType ( TcType, ThetaType, mkTyVarTys, mkTyConApp, tcTyConAppTyCon, @@ -247,7 +247,7 @@ tcDeriving tycl_decls ----------------------------------------- deriveOrdinaryStuff [] -- Short cut - = returnM ([], emptyBag) + = returnM ([], emptyLHsBinds) deriveOrdinaryStuff eqns = do { -- Take the equation list and solve it, to deliver a list of @@ -327,7 +327,7 @@ makeDerivEqns tycl_decls mk_eqn (new_or_data, tycon_name, hs_deriv_ty) = tcLookupTyCon tycon_name `thenM` \ tycon -> - addSrcSpan (srcLocSpan (getSrcLoc tycon)) $ + setSrcSpan (srcLocSpan (getSrcLoc tycon)) $ addErrCtxt (derivCtxt Nothing tycon) $ tcExtendTyVarEnv (tyConTyVars tycon) $ -- Deriving preds may (now) mention -- the type variables for the type constructor @@ -431,7 +431,7 @@ makeDerivEqns tycl_decls -- There's no 'corece' needed because after the type checker newtypes -- are transparent. - sc_theta = substTheta (mkTyVarSubst clas_tyvars inst_tys) + sc_theta = substTheta (zipTvSubst clas_tyvars inst_tys) (classSCTheta clas) -- If there are no tyvars, there's no need @@ -544,16 +544,13 @@ mkDataTypeEqn tycon clas where tyvars = tyConTyVars tycon constraints = extra_constraints ++ ordinary_constraints - extra_constraints = tyConTheta tycon + extra_constraints = tyConStupidTheta tycon -- "extra_constraints": see note [Data decl contexts] above ordinary_constraints = [ mkClassPred clas [arg_ty] | data_con <- tyConDataCons tycon, arg_ty <- dataConOrigArgTys data_con, - -- Use the same type variables - -- as the type constructor, - -- hence no need to instantiate not (isUnLiftedType arg_ty) -- No constraints for unlifted types? ] @@ -606,9 +603,9 @@ andCond c1 c2 tc = case c1 tc of cond_std :: Condition cond_std (gla_exts, tycon) - | any isExistentialDataCon data_cons = Just existential_why - | null data_cons = Just no_cons_why - | otherwise = Nothing + | any (not . isVanillaDataCon) data_cons = Just existential_why + | null data_cons = Just no_cons_why + | otherwise = Nothing where data_cons = tyConDataCons tycon no_cons_why = quotes (ppr tycon) <+> ptext SLIT("has no data constructors") @@ -711,7 +708,7 @@ solveDerivEqns orig_eqns ------------------------------------------------------------------ gen_soln (_, clas, tc,tyvars,deriv_rhs) - = addSrcSpan (srcLocSpan (getSrcLoc tc)) $ + = setSrcSpan (srcLocSpan (getSrcLoc tc)) $ addErrCtxt (derivCtxt (Just clas) tc) $ tcSimplifyDeriv tyvars deriv_rhs `thenM` \ theta -> returnM (sortLe (<=) theta) -- Canonicalise before returning the soluction @@ -815,7 +812,7 @@ genInst dfun genDerivBinds clas fix_env tycon | className clas `elem` typeableClassNames - = (gen_Typeable_binds tycon, emptyBag) + = (gen_Typeable_binds tycon, emptyLHsBinds) | otherwise = case assocMaybe gen_list (getUnique clas) of @@ -836,7 +833,7 @@ genDerivBinds clas fix_env tycon -- no_aux_binds is used for generators that don't -- need to produce any auxiliary bindings - no_aux_binds f fix_env tc = (f fix_env tc, emptyBag) + no_aux_binds f fix_env tc = (f fix_env tc, emptyLHsBinds) ignore_fix_env f fix_env tc = f tc \end{code} @@ -887,7 +884,7 @@ genTaggeryBinds dfuns do_con2tag acc_Names tycon | isDataTyCon tycon && ((we_are_deriving eqClassKey tycon - && any isNullaryDataCon (tyConDataCons tycon)) + && any isNullarySrcDataCon (tyConDataCons tycon)) || (we_are_deriving ordClassKey tycon && not (isProductTyCon tycon)) || (we_are_deriving enumClassKey tycon) diff --git a/ghc/compiler/typecheck/TcEnv.lhs b/ghc/compiler/typecheck/TcEnv.lhs index 1c77e4d129..f80fe86b18 100644 --- a/ghc/compiler/typecheck/TcEnv.lhs +++ b/ghc/compiler/typecheck/TcEnv.lhs @@ -13,12 +13,12 @@ module TcEnv( tcLookupLocatedGlobal, tcLookupGlobal, tcLookupGlobalId, tcLookupTyCon, tcLookupClass, tcLookupDataCon, tcLookupLocatedGlobalId, tcLookupLocatedTyCon, - tcLookupLocatedClass, tcLookupLocatedDataCon, + tcLookupLocatedClass, -- Local environment tcExtendKindEnv, - tcExtendTyVarEnv, tcExtendTyVarEnv2, - tcExtendLocalValEnv, tcExtendLocalValEnv2, + tcExtendTyVarEnv, tcExtendTyVarEnv2, + tcExtendIdEnv, tcExtendIdEnv1, tcExtendIdEnv2, tcLookup, tcLookupLocated, tcLookupLocalIds, tcLookupId, tcLookupTyVar, lclEnvElts, getInLocalScope, findGlobals, @@ -51,7 +51,7 @@ import TcRnMonad import TcMType ( zonkTcType, zonkTcTyVar, zonkTcTyVarsAndFV ) import TcType ( Type, TcKind, TcTyVar, TcTyVarSet, tyVarsOfType, tyVarsOfTypes, tcSplitDFunTy, mkGenTyConApp, - getDFunTyKey, tcTyConAppTyCon, tyVarBindingInfo, + getDFunTyKey, tcTyConAppTyCon, tidyOpenType, tidyOpenTyVar ) import qualified Type ( getTyVar_maybe ) @@ -72,7 +72,6 @@ import HscTypes ( DFunId, extendTypeEnvList, lookupType, import SrcLoc ( SrcLoc, Located(..) ) import Outputable -import Maybe ( isJust ) \end{code} @@ -100,7 +99,7 @@ tcLookupGlobal name then -- It's defined in this module case lookupNameEnv (tcg_type_env env) name of Just thing -> return thing - Nothing -> notFound "tcLookupGlobal" name + Nothing -> notFound name -- Panic! else do -- It's imported { (eps,hpt) <- getEpsAndHpt @@ -140,9 +139,6 @@ tcLookupTyCon name tcLookupLocatedGlobalId :: Located Name -> TcM Id tcLookupLocatedGlobalId = addLocM tcLookupId -tcLookupLocatedDataCon :: Located Name -> TcM DataCon -tcLookupLocatedDataCon = addLocM tcLookupDataCon - tcLookupLocatedClass :: Located Name -> TcM Class tcLookupLocatedClass = addLocM tcLookupClass @@ -281,22 +277,21 @@ tc_extend_tv_env binds tyvars thing_inside \begin{code} -tcExtendLocalValEnv :: [TcId] -> TcM a -> TcM a -tcExtendLocalValEnv ids thing_inside - = getLclEnv `thenM` \ env -> - let - extra_global_tyvars = tyVarsOfTypes [idType id | id <- ids] - th_lvl = thLevel (tcl_th_ctxt env) - proc_lvl = proc_level (tcl_arrow_ctxt env) - extra_env = [(idName id, ATcId id th_lvl proc_lvl) | id <- ids] - le' = extendNameEnvList (tcl_env env) extra_env - rdr_env' = extendLocalRdrEnv (tcl_rdr env) (map idName ids) - in - tc_extend_gtvs (tcl_tyvars env) extra_global_tyvars `thenM` \ gtvs' -> - setLclEnv (env {tcl_env = le', tcl_tyvars = gtvs', tcl_rdr = rdr_env'}) thing_inside - -tcExtendLocalValEnv2 :: [(Name,TcId)] -> TcM a -> TcM a -tcExtendLocalValEnv2 names_w_ids thing_inside +tcExtendIdEnv :: [TcId] -> TcM a -> TcM a +-- Invariant: the TcIds are fully zonked. Reasons: +-- (a) The kinds of the forall'd type variables are defaulted +-- (see Kind.defaultKind, done in zonkQuantifiedTyVar) +-- (b) There are no via-Indirect occurrences of the bound variables +-- in the types, because instantiation does not look through such things +-- (c) The call to tyVarsOfTypes is ok without looking through refs +tcExtendIdEnv ids thing_inside = tcExtendIdEnv2 [(idName id, id) | id <- ids] thing_inside + +tcExtendIdEnv1 :: Name -> TcId -> TcM a -> TcM a +tcExtendIdEnv1 name id thing_inside = tcExtendIdEnv2 [(name,id)] thing_inside + +tcExtendIdEnv2 :: [(Name,TcId)] -> TcM a -> TcM a +-- Invariant: the TcIds are fully zonked (see tcExtendIdEnv above) +tcExtendIdEnv2 names_w_ids thing_inside = getLclEnv `thenM` \ env -> let extra_global_tyvars = tyVarsOfTypes [idType id | (name,id) <- names_w_ids] @@ -361,8 +356,7 @@ find_thing ignore_it tidy_env (ATyVar tv) tv == tv' = empty | otherwise = equals <+> ppr tidy_ty -- It's ok to use Type.getTyVar_maybe because ty is zonked by now - - bound_at = tyVarBindingInfo tv + bound_at = ptext SLIT("bound at:") <+> ppr (getSrcLoc tv) in returnM (tidy_env2, Just msg) \end{code} @@ -603,8 +597,9 @@ simpleInstInfoTyCon inst = tcTyConAppTyCon (simpleInstInfoTy inst) %************************************************************************ \begin{code} -notFound wheRe name = failWithTc (text wheRe <> colon <+> quotes (ppr name) <+> - ptext SLIT("is not in scope")) +notFound name + = failWithTc (ptext SLIT("GHC internal error:") <+> quotes (ppr name) <+> + ptext SLIT("is not in scope")) wrongThingErr expected thing name = failWithTc (pp_thing thing <+> quotes (ppr name) <+> diff --git a/ghc/compiler/typecheck/TcExpr.hi-boot-6 b/ghc/compiler/typecheck/TcExpr.hi-boot-6 index f5d0d50e51..b48197b8a8 100644 --- a/ghc/compiler/typecheck/TcExpr.hi-boot-6 +++ b/ghc/compiler/typecheck/TcExpr.hi-boot-6 @@ -10,6 +10,10 @@ tcCheckRho :: -> TcType.TcType -> TcRnTypes.TcM (HsExpr.LHsExpr Var.Id) +tcInferRho :: + HsExpr.LHsExpr Name.Name + -> TcRnTypes.TcM (HsExpr.LHsExpr Var.Id, TcType.TcType) + tcMonoExpr :: HsExpr.LHsExpr Name.Name -> TcUnify.Expected TcType.TcType diff --git a/ghc/compiler/typecheck/TcExpr.lhs b/ghc/compiler/typecheck/TcExpr.lhs index 6a3c5145b2..dd6ed24495 100644 --- a/ghc/compiler/typecheck/TcExpr.lhs +++ b/ghc/compiler/typecheck/TcExpr.lhs @@ -19,16 +19,14 @@ import qualified DsMeta import HsSyn ( HsExpr(..), LHsExpr, HsLit(..), ArithSeqInfo(..), recBindFields, HsMatchContext(..), HsRecordBinds, mkHsApp, nlHsVar ) -import TcHsSyn ( hsLitType, mkHsDictApp, mkHsTyApp, (<$>) ) +import TcHsSyn ( hsLitType, (<$>) ) import TcRnMonad -import TcUnify ( Expected(..), newHole, zapExpectedType, zapExpectedTo, tcSubExp, tcGen, - unifyFunTy, zapToListTy, zapToPArrTy, zapToTupleTy ) +import TcUnify ( Expected(..), tcInfer, zapExpectedType, zapExpectedTo, tcSubExp, tcGen, + unifyFunTys, zapToListTy, zapToTyConApp, readExpectedType ) import BasicTypes ( isMarkedStrict ) import Inst ( InstOrigin(..), newOverloadedLit, newMethodFromName, newIPDict, - newDicts, newMethodWithGivenTy, - instToId, tcInstCall, tcInstDataCon - ) + newDicts, newMethodWithGivenTy, tcInstStupidTheta, tcInstCall ) import TcBinds ( tcBindsAndThen ) import TcEnv ( tcLookup, tcLookupId, checkProcLevel, tcLookupDataCon, tcLookupGlobalId @@ -37,23 +35,22 @@ import TcArrows ( tcProc ) import TcMatches ( tcMatchesCase, tcMatchLambda, tcDoStmts, tcThingWithSig, TcMatchCtxt(..) ) import TcHsType ( tcHsSigType, UserTypeCtxt(..) ) import TcPat ( badFieldCon ) -import TcMType ( tcInstTyVars, tcInstType, newTyVarTy, zonkTcType ) -import TcType ( TcType, TcSigmaType, TcRhoType, TyVarDetails(VanillaTv), +import TcMType ( tcInstTyVars, tcInstType, newTyFlexiVarTy, zonkTcType, readMetaTyVar ) +import TcType ( Type, TcTyVar, TcType, TcSigmaType, TcRhoType, MetaDetails(..), tcSplitFunTys, tcSplitTyConApp, mkTyVarTys, - isSigmaTy, mkFunTy, mkFunTys, - mkTyConApp, tyVarsOfTypes, isLinearPred, + isSigmaTy, mkFunTy, mkTyConApp, tyVarsOfTypes, isLinearPred, tcSplitSigmaTy, tidyOpenType ) import Kind ( openTypeKind, liftedTypeKind, argTypeKind ) -import FieldLabel ( FieldLabel, fieldLabelName, fieldLabelType, fieldLabelTyCon ) import Id ( idType, recordSelectorFieldLabel, isRecordSelector ) import DataCon ( DataCon, dataConFieldLabels, dataConStrictMarks, dataConWrapId ) import Name ( Name ) -import TyCon ( TyCon, tyConTyVars, tyConTheta, tyConDataCons ) -import Subst ( mkTopTyVarSubst, substTheta, substTy ) +import TyCon ( TyCon, FieldLabel, tyConTyVars, tyConStupidTheta, + tyConDataCons, tyConFields ) +import Type ( zipTopTvSubst, mkTopTvSubst, substTheta, substTy ) import VarSet ( emptyVarSet, elemVarSet ) -import TysWiredIn ( boolTy ) +import TysWiredIn ( boolTy, parrTyCon, tupleTyCon ) import PrelNames ( enumFromName, enumFromThenName, enumFromToName, enumFromThenToName, enumFromToPName, enumFromThenToPName @@ -63,6 +60,7 @@ import CmdLineOpts import HscTypes ( TyThing(..) ) import SrcLoc ( Located(..), unLoc, getLoc ) import Util +import Maybes ( catMaybes ) import Outputable import FastString @@ -108,12 +106,9 @@ tcCheckRho :: LHsExpr Name -> TcRhoType -> TcM (LHsExpr TcId) tcCheckRho expr rho_ty = tcMonoExpr expr (Check rho_ty) tcInferRho :: LHsExpr Name -> TcM (LHsExpr TcId, TcRhoType) -tcInferRho (L loc (HsVar name)) = addSrcSpan loc $ - do { (e,ty) <- tcId name; return (L loc e, ty)} -tcInferRho expr = newHole `thenM` \ hole -> - tcMonoExpr expr (Infer hole) `thenM` \ expr' -> - readMutVar hole `thenM` \ rho_ty -> - returnM (expr', rho_ty) +tcInferRho (L loc (HsVar name)) = setSrcSpan loc $ do + { (e,_,ty) <- tcId name; return (L loc e, ty)} +tcInferRho expr = tcInfer (tcMonoExpr expr) \end{code} @@ -132,21 +127,21 @@ tcMonoExpr :: LHsExpr Name -- Expession to type check -> TcM (LHsExpr TcId) tcMonoExpr (L loc expr) res_ty - = addSrcSpan loc (do { expr' <- tc_expr expr res_ty + = setSrcSpan loc (do { expr' <- tc_expr expr res_ty ; return (L loc expr') }) tc_expr :: HsExpr Name -> Expected TcRhoType -> TcM (HsExpr TcId) tc_expr (HsVar name) res_ty - = tcId name `thenM` \ (expr', id_ty) -> - tcSubExp res_ty id_ty `thenM` \ co_fn -> - returnM (co_fn <$> expr') + = do { (expr', _, id_ty) <- tcId name + ; co_fn <- tcSubExp res_ty id_ty + ; returnM (co_fn <$> expr') } tc_expr (HsIPVar ip) res_ty = -- Implicit parameters must have a *tau-type* not a -- type scheme. We enforce this by creating a fresh -- type variable as its type. (Because res_ty may not -- be a tau-type.) - newTyVarTy argTypeKind `thenM` \ ip_ty -> + newTyFlexiVarTy argTypeKind `thenM` \ ip_ty -> -- argTypeKind: it can't be an unboxed tuple newIPDict (IPOccOrigin ip) ip ip_ty `thenM` \ (ip', inst) -> extendLIE inst `thenM_` @@ -224,7 +219,7 @@ a type error will occur if they aren't. tc_expr in_expr@(SectionL arg1 op) res_ty = tcInferRho op `thenM` \ (op', op_ty) -> - split_fun_ty op_ty 2 {- two args -} `thenM` \ ([arg1_ty, arg2_ty], op_res_ty) -> + unifyFunTys 2 op_ty {- two args -} `thenM` \ ([arg1_ty, arg2_ty], op_res_ty) -> tcArg op (arg1, arg1_ty, 1) `thenM` \ arg1' -> addErrCtxt (exprCtxt in_expr) $ tcSubExp res_ty (mkFunTy arg2_ty op_res_ty) `thenM` \ co_fn -> @@ -235,7 +230,7 @@ tc_expr in_expr@(SectionL arg1 op) res_ty tc_expr in_expr@(SectionR op arg2) res_ty = tcInferRho op `thenM` \ (op', op_ty) -> - split_fun_ty op_ty 2 {- two args -} `thenM` \ ([arg1_ty, arg2_ty], op_res_ty) -> + unifyFunTys 2 op_ty {- two args -} `thenM` \ ([arg1_ty, arg2_ty], op_res_ty) -> tcArg op (arg2, arg2_ty, 2) `thenM` \ arg2' -> addErrCtxt (exprCtxt in_expr) $ tcSubExp res_ty (mkFunTy arg1_ty op_res_ty) `thenM` \ co_fn -> @@ -245,7 +240,7 @@ tc_expr in_expr@(SectionR op arg2) res_ty tc_expr in_expr@(OpApp arg1 op fix arg2) res_ty = tcInferRho op `thenM` \ (op', op_ty) -> - split_fun_ty op_ty 2 {- two args -} `thenM` \ ([arg1_ty, arg2_ty], op_res_ty) -> + unifyFunTys 2 op_ty {- two args -} `thenM` \ ([arg1_ty, arg2_ty], op_res_ty) -> tcArg op (arg1, arg1_ty, 1) `thenM` \ arg1' -> tcArg op (arg2, arg2_ty, 2) `thenM` \ arg2' -> addErrCtxt (exprCtxt in_expr) $ @@ -258,28 +253,27 @@ tc_expr (HsLet binds (L loc expr)) res_ty = tcBindsAndThen glue binds -- Bindings to check - (tc_expr expr res_ty) + (setSrcSpan loc $ tc_expr expr res_ty) where glue bind expr = HsLet [bind] (L loc expr) -tc_expr in_expr@(HsCase scrut matches) res_ty - = addErrCtxt (caseCtxt in_expr) $ - - -- Typecheck the case alternatives first. +tc_expr in_expr@(HsCase scrut matches) exp_ty + = -- We used to typecheck the case alternatives first. -- The case patterns tend to give good type info to use -- when typechecking the scrutinee. For example -- case (map f) of -- (x:xs) -> ... -- will report that map is applied to too few arguments - - tcMatchesCase match_ctxt matches res_ty `thenM` \ (scrut_ty, matches') -> - - addErrCtxt (caseScrutCtxt scrut) ( - tcCheckRho scrut scrut_ty - ) `thenM` \ scrut' -> - - returnM (HsCase scrut' matches') - where + -- + -- But now, in the GADT world, we need to typecheck the scrutinee + -- first, to get type info that may be refined in the case alternatives + addErrCtxt (caseScrutCtxt scrut) + (tcInferRho scrut) `thenM` \ (scrut', scrut_ty) -> + + addErrCtxt (caseCtxt in_expr) $ + tcMatchesCase match_ctxt scrut_ty matches exp_ty `thenM` \ matches' -> + returnM (HsCase scrut' matches') + where match_ctxt = MC { mc_what = CaseAlt, mc_body = tcMonoExpr } @@ -310,18 +304,17 @@ tc_expr in_expr@(ExplicitList _ exprs) res_ty -- Non-empty list tcCheckRho expr elt_ty tc_expr in_expr@(ExplicitPArr _ exprs) res_ty -- maybe empty - = zapToPArrTy res_ty `thenM` \ elt_ty -> - mappM (tc_elt elt_ty) exprs `thenM` \ exprs' -> - returnM (ExplicitPArr elt_ty exprs') + = do { [elt_ty] <- zapToTyConApp parrTyCon res_ty + ; exprs' <- mappM (tc_elt elt_ty) exprs + ; return (ExplicitPArr elt_ty exprs') } where tc_elt elt_ty expr - = addErrCtxt (parrCtxt expr) $ - tcCheckRho expr elt_ty + = addErrCtxt (parrCtxt expr) (tcCheckRho expr elt_ty) tc_expr (ExplicitTuple exprs boxity) res_ty - = zapToTupleTy boxity (length exprs) res_ty `thenM` \ arg_tys -> - tcCheckRhos exprs arg_tys `thenM` \ exprs' -> - returnM (ExplicitTuple exprs' boxity) + = do { arg_tys <- zapToTyConApp (tupleTyCon boxity (length exprs)) res_ty + ; exprs' <- tcCheckRhos exprs arg_tys + ; return (ExplicitTuple exprs' boxity) } tc_expr (HsProc pat cmd) res_ty = tcProc pat cmd res_ty `thenM` \ (pat', cmd') -> @@ -343,9 +336,9 @@ tc_expr e@(HsArrForm _ _ _) _ %************************************************************************ \begin{code} -tc_expr expr@(RecordCon con@(L _ con_name) rbinds) res_ty +tc_expr expr@(RecordCon con@(L loc con_name) rbinds) res_ty = addErrCtxt (recordConCtxt expr) $ - addLocM tcId con `thenM` \ (con_expr, con_tau) -> + addLocM tcId con `thenM` \ (con_expr, _, con_tau) -> let (_, record_ty) = tcSplitFunTys con_tau (tycon, ty_args) = tcSplitTyConApp record_ty @@ -412,7 +405,7 @@ tc_expr expr@(RecordUpd record_expr rbinds) res_ty -- The renamer has already checked that they -- are all in scope let - bad_guys = [ addSrcSpan loc $ addErrTc (notSelector field_name) + bad_guys = [ setSrcSpan loc $ addErrTc (notSelector field_name) | (L loc field_name, sel_id) <- field_names `zip` sel_ids, not (isRecordSelector sel_id) -- Excludes class ops ] @@ -424,18 +417,17 @@ tc_expr expr@(RecordUpd record_expr rbinds) res_ty let -- It's OK to use the non-tc splitters here (for a selector) sel_id : _ = sel_ids - field_lbl = recordSelectorFieldLabel sel_id -- We've failed already if - tycon = fieldLabelTyCon field_lbl -- it's not a field label - data_cons = tyConDataCons tycon + (tycon, _) = recordSelectorFieldLabel sel_id -- We've failed already if + data_cons = tyConDataCons tycon -- it's not a field label tycon_tyvars = tyConTyVars tycon -- The data cons use the same type vars in - tcInstTyVars VanillaTv tycon_tyvars `thenM` \ (_, result_inst_tys, inst_env) -> + tcInstTyVars tycon_tyvars `thenM` \ (_, result_inst_tys, inst_env) -> -- STEP 2 -- Check that at least one constructor has all the named fields -- i.e. has an empty set of bad fields returned by badFields checkTc (any (null . badFields rbinds) data_cons) - (badFieldsUpd rbinds) `thenM_` + (badFieldsUpd rbinds) `thenM_` -- STEP 3 -- Typecheck the update bindings. @@ -454,7 +446,7 @@ tc_expr expr@(RecordUpd record_expr rbinds) res_ty -- WARNING: this code assumes that all data_cons in a common tycon -- have FieldLabels abstracted over the same tyvars. let - upd_field_lbls = map recordSelectorFieldLabel (recBindFields rbinds') + upd_field_lbls = recBindFields rbinds con_field_lbls_s = map dataConFieldLabels data_cons -- A constructor is only relevant to this process if @@ -463,11 +455,13 @@ tc_expr expr@(RecordUpd record_expr rbinds) res_ty is_relevant con_field_lbls = all (`elem` con_field_lbls) upd_field_lbls non_upd_field_lbls = concat relevant_field_lbls_s `minusList` upd_field_lbls - common_tyvars = tyVarsOfTypes (map fieldLabelType non_upd_field_lbls) + common_tyvars = tyVarsOfTypes [ty | (fld,ty,_) <- tyConFields tycon, + fld `elem` non_upd_field_lbls] mk_inst_ty tyvar result_inst_ty | tyvar `elemVarSet` common_tyvars = returnM result_inst_ty -- Same as result type - | otherwise = newTyVarTy liftedTypeKind -- Fresh type +-- gaw 2004 FIX? + | otherwise = newTyFlexiVarTy liftedTypeKind -- Fresh type in zipWithM mk_inst_ty tycon_tyvars result_inst_tys `thenM` \ inst_tys -> @@ -486,7 +480,7 @@ tc_expr expr@(RecordUpd record_expr rbinds) res_ty -- What dictionaries do we need? -- We just take the context of the type constructor let - theta' = substTheta inst_env (tyConTheta tycon) + theta' = substTheta inst_env (tyConStupidTheta tycon) in newDicts RecordUpdOrigin theta' `thenM` \ dicts -> extendLIEs dicts `thenM_` @@ -548,7 +542,7 @@ tc_expr in_expr@(ArithSeqIn seq@(FromThenTo expr1 expr2 expr3)) res_ty tc_expr in_expr@(PArrSeqIn seq@(FromTo expr1 expr2)) res_ty = addErrCtxt (parrSeqCtxt in_expr) $ - zapToPArrTy res_ty `thenM` \ elt_ty -> + zapToTyConApp parrTyCon res_ty `thenM` \ [elt_ty] -> tcCheckRho expr1 elt_ty `thenM` \ expr1' -> tcCheckRho expr2 elt_ty `thenM` \ expr2' -> newMethodFromName (PArrSeqOrigin seq) @@ -558,7 +552,7 @@ tc_expr in_expr@(PArrSeqIn seq@(FromTo expr1 expr2)) res_ty tc_expr in_expr@(PArrSeqIn seq@(FromThenTo expr1 expr2 expr3)) res_ty = addErrCtxt (parrSeqCtxt in_expr) $ - zapToPArrTy res_ty `thenM` \ elt_ty -> + zapToTyConApp parrTyCon res_ty `thenM` \ [elt_ty] -> tcCheckRho expr1 elt_ty `thenM` \ expr1' -> tcCheckRho expr2 elt_ty `thenM` \ expr2' -> tcCheckRho expr3 elt_ty `thenM` \ expr3' -> @@ -611,51 +605,96 @@ tc_expr other _ = pprPanic "tcMonoExpr" (ppr other) tcApp :: LHsExpr Name -> [LHsExpr Name] -- Function and args -> Expected TcRhoType -- Expected result type of application - -> TcM (HsExpr TcId) -- Translated fun and args + -> TcM (HsExpr TcId) -- Translated fun and args tcApp (L _ (HsApp e1 e2)) args res_ty = tcApp e1 (e2:args) res_ty -- Accumulate the arguments tcApp fun args res_ty - = -- First type-check the function - tcInferRho fun `thenM` \ (fun', fun_ty) -> - - addErrCtxt (wrongArgsCtxt "too many" fun args) ( - traceTc (text "tcApp" <+> (ppr fun $$ ppr fun_ty)) `thenM_` - split_fun_ty fun_ty (length args) - ) `thenM` \ (expected_arg_tys, actual_result_ty) -> - - -- Unify with expected result before (was: after) type-checking the args - -- so that the info from res_ty (was: args) percolates to args (was actual_result_ty). - -- This is when we might detect a too-few args situation. - -- (One can think of cases when the opposite order would give - -- a better error message.) - -- [March 2003: I'm experimenting with putting this first. Here's an - -- example where it actually makes a real difference - -- class C t a b | t a -> b - -- instance C Char a Bool - -- - -- data P t a = forall b. (C t a b) => MkP b - -- data Q t = MkQ (forall a. P t a) - - -- f1, f2 :: Q Char; - -- f1 = MkQ (MkP True) - -- f2 = MkQ (MkP True :: forall a. P Char a) - -- - -- With the change, f1 will type-check, because the 'Char' info from - -- the signature is propagated into MkQ's argument. With the check - -- in the other order, the extra signature in f2 is reqd.] - - addErrCtxtM (checkArgsCtxt fun args res_ty actual_result_ty) - (tcSubExp res_ty actual_result_ty) `thenM` \ co_fn -> + = do { (fun', fun_tvs, fun_tau) <- tcFun fun -- Type-check the function + + -- Extract its argument types + ; (expected_arg_tys, actual_res_ty) + <- addErrCtxt (wrongArgsCtxt "too many" fun args) $ do + { traceTc (text "tcApp" <+> (ppr fun $$ ppr fun_tau)) + ; unifyFunTys (length args) fun_tau } + + + ; case res_ty of + Check _ -> do -- Connect to result type first + -- See Note [Push result type in] + { co_fn <- tcResult fun args res_ty actual_res_ty + ; the_app' <- tcArgs fun fun' args expected_arg_tys + ; traceTc (text "tcApp: check" <+> vcat [ppr fun <+> ppr args, + ppr the_app', ppr actual_res_ty]) + ; returnM (co_fn <$> the_app') } + + Infer _ -> do -- Type check args first, then + -- refine result type, then do tcResult + { the_app' <- tcArgs fun fun' args expected_arg_tys + ; actual_res_ty' <- refineResultTy fun_tvs actual_res_ty + ; co_fn <- tcResult fun args res_ty actual_res_ty' + ; traceTc (text "tcApp: infer" <+> vcat [ppr fun <+> ppr args, ppr the_app', + ppr actual_res_ty, ppr actual_res_ty']) + ; returnM (co_fn <$> the_app') } + } + +-- Note [Push result type in] +-- +-- Unify with expected result before (was: after) type-checking the args +-- so that the info from res_ty (was: args) percolates to args (was actual_res_ty). +-- This is when we might detect a too-few args situation. +-- (One can think of cases when the opposite order would give +-- a better error message.) +-- [March 2003: I'm experimenting with putting this first. Here's an +-- example where it actually makes a real difference +-- class C t a b | t a -> b +-- instance C Char a Bool +-- +-- data P t a = forall b. (C t a b) => MkP b +-- data Q t = MkQ (forall a. P t a) - -- Now typecheck the args - mappM (tcArg fun) - (zip3 args expected_arg_tys [1..]) `thenM` \ args' -> +-- f1, f2 :: Q Char; +-- f1 = MkQ (MkP True) +-- f2 = MkQ (MkP True :: forall a. P Char a) +-- +-- With the change, f1 will type-check, because the 'Char' info from +-- the signature is propagated into MkQ's argument. With the check +-- in the other order, the extra signature in f2 is reqd.] + +---------------- +tcFun :: LHsExpr Name -> TcM (LHsExpr TcId, [TcTyVar], TcRhoType) +-- Instantiate the function, returning the type variables used +-- If the function isn't simple, infer its type, and return no +-- type variables +tcFun (L loc (HsVar f)) = setSrcSpan loc $ do + { (fun', tvs, fun_tau) <- tcId f + ; return (L loc fun', tvs, fun_tau) } +tcFun fun = do { (fun', fun_tau) <- tcInfer (tcMonoExpr fun) + ; return (fun', [], fun_tau) } + +---------------- +tcArgs :: LHsExpr Name -- The function (for error messages) + -> LHsExpr TcId -- The function (to build into result) + -> [LHsExpr Name] -> [TcSigmaType] -- Actual arguments and expected arg types + -> TcM (HsExpr TcId) -- Resulting application + +tcArgs fun fun' args expected_arg_tys + = do { args' <- mappM (tcArg fun) (zip3 args expected_arg_tys [1..]) + ; return (unLoc (foldl mkHsApp fun' args')) } - returnM (co_fn <$> unLoc (foldl mkHsApp fun' args')) +tcArg :: LHsExpr Name -- The function (for error messages) + -> (LHsExpr Name, TcSigmaType, Int) -- Actual argument and expected arg type + -> TcM (LHsExpr TcId) -- Resulting argument +tcArg fun (arg, ty, arg_no) = addErrCtxt (funAppCtxt fun arg arg_no) + (tcCheckSigma arg ty) +---------------- +tcResult fun args res_ty actual_res_ty + = addErrCtxtM (checkArgsCtxt fun args res_ty actual_res_ty) + (tcSubExp res_ty actual_res_ty) +---------------- -- If an error happens we try to figure out whether the -- function has been given too many or too few arguments, -- and say so. @@ -682,30 +721,23 @@ checkArgsCtxt fun args (Check expected_res_ty) actual_res_ty tidy_env in returnM (env2, message) - -split_fun_ty :: TcRhoType -- The type of the function - -> Int -- Number of arguments - -> TcM ([TcType], -- Function argument types - TcType) -- Function result types - -split_fun_ty fun_ty 0 - = returnM ([], fun_ty) - -split_fun_ty fun_ty n - = -- Expect the function to have type A->B - unifyFunTy fun_ty `thenM` \ (arg_ty, res_ty) -> - split_fun_ty res_ty (n-1) `thenM` \ (arg_tys, final_res_ty) -> - returnM (arg_ty:arg_tys, final_res_ty) -\end{code} - -\begin{code} -tcArg :: LHsExpr Name -- The function (for error messages) - -> (LHsExpr Name, TcSigmaType, Int) -- Actual argument and expected arg type - -> TcM (LHsExpr TcId) -- Resulting argument - -tcArg the_fun (arg, expected_arg_ty, arg_no) - = addErrCtxt (funAppCtxt the_fun arg arg_no) $ - tcCheckSigma arg expected_arg_ty +---------------- +refineResultTy :: [TcTyVar] -- Newly instantiated meta-tyvars of the function + -> TcType -- Result type, instantiated with those tyvars + -> TcM TcType -- Refined result type +-- De-wobblify the result type, by taking account what we learned +-- from type-checking the arguments. Just one level of de-wobblification +-- though. What a hack! +refineResultTy tvs res_ty + = do { mb_prs <- mapM mk_pr tvs + ; let subst = mkTopTvSubst (catMaybes mb_prs) + ; return (substTy subst res_ty) } + where + mk_pr tv = do { details <- readMetaTyVar tv + ; case details of + Indirect ty -> return (Just (tv,ty)) + other -> return Nothing + } \end{code} @@ -738,40 +770,44 @@ This gets a bit less sharing, but b) perhaps fewer separated lambdas \begin{code} -tcId :: Name -> TcM (HsExpr TcId, TcRhoType) +tcId :: Name -> TcM (HsExpr TcId, [TcTyVar], TcRhoType) + -- Return the type variables at which the function + -- is instantiated, as well as the translated variable and its type + tcId name -- Look up the Id and instantiate its type - = -- First check whether it's a DataCon - -- Reason: we must not forget to chuck in the - -- constraints from their "silly context" - tcLookup name `thenM` \ thing -> + = tcLookup name `thenM` \ thing -> case thing of { - AGlobal (ADataCon data_con) -> inst_data_con data_con - ; AGlobal (AnId id) -> loop (HsVar id) (idType id) + AGlobal (AnId id) -> instantiate id -- A global cannot possibly be ill-staged -- nor does it need the 'lifting' treatment - ; ATcId id th_level proc_level -> tc_local_id id th_level proc_level - ; other -> pprPanic "tcId" (ppr name $$ ppr thing) + ; AGlobal (ADataCon con) -- Similar, but instantiate the stupid theta too + -> do { (expr, tvs, tau) <- instantiate (dataConWrapId con) + ; tcInstStupidTheta con (mkTyVarTys tvs) + -- Remember to chuck in the constraints from the "silly context" + ; return (expr, tvs, tau) } + + ; ATcId id th_level proc_level + -> do { checkProcLevel id proc_level + ; tc_local_id id th_level } + + ; other -> pprPanic "tcId" (ppr name $$ ppr thing) } where #ifndef GHCI - tc_local_id id th_bind_lvl proc_lvl -- Non-TH case - = checkProcLevel id proc_lvl `thenM_` - loop (HsVar id) (idType id) + tc_local_id id th_bind_lvl -- Non-TH case + = instantiate id #else /* GHCI and TH is on */ - tc_local_id id th_bind_lvl proc_lvl -- TH case - = checkProcLevel id proc_lvl `thenM_` - - -- Check for cross-stage lifting + tc_local_id id th_bind_lvl -- TH case + = -- Check for cross-stage lifting getStage `thenM` \ use_stage -> case use_stage of Brack use_lvl ps_var lie_var | use_lvl > th_bind_lvl -> -- E.g. \x -> [| h x |] -- We must behave as if the reference to x was - -- h $(lift x) -- We use 'x' itself as the splice proxy, used by -- the desugarer to stitch it all back together. @@ -796,27 +832,30 @@ tcId name -- Look up the Id and instantiate its type readMutVar ps_var `thenM` \ ps -> writeMutVar ps_var ((name, nlHsApp (nlHsVar lift) (nlHsVar id)) : ps) `thenM_` - returnM (HsVar id, id_ty)) + returnM (HsVar id, [], id_ty)) other -> checkWellStaged (quotes (ppr id)) th_bind_lvl use_stage `thenM_` - loop (HsVar id) (idType id) + instantiate id #endif /* GHCI */ - loop (HsVar fun_id) fun_ty + instantiate :: TcId -> TcM (HsExpr TcId, [TcTyVar], TcRhoType) + instantiate fun_id = loop (HsVar fun_id) [] (idType fun_id) + + loop (HsVar fun_id) tvs fun_ty | want_method_inst fun_ty - = tcInstType VanillaTv fun_ty `thenM` \ (tyvars, theta, tau) -> + = tcInstType fun_ty `thenM` \ (tyvars, theta, tau) -> newMethodWithGivenTy orig fun_id (mkTyVarTys tyvars) theta tau `thenM` \ meth_id -> - loop (HsVar meth_id) tau + loop (HsVar meth_id) (tvs ++ tyvars) tau - loop fun fun_ty + loop fun tvs fun_ty | isSigmaTy fun_ty - = tcInstCall orig fun_ty `thenM` \ (inst_fn, tau) -> - loop (inst_fn <$> fun) tau + = tcInstCall orig fun_ty `thenM` \ (inst_fn, new_tvs, tau) -> + loop (inst_fn <$> fun) (tvs ++ new_tvs) tau | otherwise - = returnM (fun, fun_ty) + = returnM (fun, tvs, fun_ty) -- Hack Alert (want_method_inst)! -- If f :: (%x :: T) => Int -> Int @@ -832,20 +871,6 @@ tcId name -- Look up the Id and instantiate its type (_,[],_) -> False -- Not overloaded (_,theta,_) -> not (any isLinearPred theta) - - -- We treat data constructors differently, because we have to generate - -- constraints for their silly theta, which no longer appears in - -- the type of dataConWrapId (see note on "stupid context" in DataCon.lhs - -- It's dual to TcPat.tcConstructor - inst_data_con data_con - = tcInstDataCon orig VanillaTv data_con `thenM` \ (ty_args, ex_dicts, arg_tys, result_ty, _) -> - extendLIEs ex_dicts `thenM_` - getSrcSpanM `thenM` \ loc -> - returnM (unLoc (mkHsDictApp (mkHsTyApp (L loc (HsVar (dataConWrapId data_con))) ty_args) - (map instToId ex_dicts)), - mkFunTys arg_tys result_ty) - -- ToDo: nasty loc/unloc stuff here - orig = OccurrenceOf name \end{code} @@ -882,31 +907,31 @@ tcRecordBinds tcRecordBinds tycon ty_args rbinds = mappM do_bind rbinds where - tenv = mkTopTyVarSubst (tyConTyVars tycon) ty_args + tenv = zipTopTvSubst (tyConTyVars tycon) ty_args - do_bind (L loc field_lbl_name, rhs) - = addErrCtxt (fieldCtxt field_lbl_name) $ - tcLookupId field_lbl_name `thenM` \ sel_id -> + do_bind (L loc field_lbl, rhs) + = addErrCtxt (fieldCtxt field_lbl) $ let - field_lbl = recordSelectorFieldLabel sel_id - field_ty = substTy tenv (fieldLabelType field_lbl) + field_ty = tyConFieldType tycon field_lbl + field_ty' = substTy tenv field_ty in + tcCheckSigma rhs field_ty' `thenM` \ rhs' -> + tcLookupId field_lbl `thenM` \ sel_id -> ASSERT( isRecordSelector sel_id ) + returnM (L loc sel_id, rhs') + +tyConFieldType :: TyCon -> FieldLabel -> Type +tyConFieldType tycon field_lbl + = case [ty | (f,ty,_) <- tyConFields tycon, f == field_lbl] of + (ty:other) -> ASSERT( null other) ty -- This lookup and assertion will surely succeed, because -- we check that the fields are indeed record selectors -- before calling tcRecordBinds - ASSERT2( fieldLabelTyCon field_lbl == tycon, ppr field_lbl ) - -- The caller of tcRecordBinds has already checked - -- that all the fields come from the same type - - tcCheckSigma rhs field_ty `thenM` \ rhs' -> - - returnM (L loc sel_id, rhs') badFields rbinds data_con = filter (not . (`elem` field_names)) (recBindFields rbinds) where - field_names = map fieldLabelName (dataConFieldLabels data_con) + field_names = dataConFieldLabels data_con checkMissingFields :: DataCon -> HsRecordBinds Name -> TcM () checkMissingFields data_con rbinds @@ -930,12 +955,12 @@ checkMissingFields data_con rbinds missing_s_fields = [ fl | (fl, str) <- field_info, isMarkedStrict str, - not (fieldLabelName fl `elem` field_names_used) + not (fl `elem` field_names_used) ] missing_ns_fields = [ fl | (fl, str) <- field_info, not (isMarkedStrict str), - not (fieldLabelName fl `elem` field_names_used) + not (fl `elem` field_names_used) ] field_names_used = recBindFields rbinds diff --git a/ghc/compiler/typecheck/TcForeign.lhs b/ghc/compiler/typecheck/TcForeign.lhs index d18fe5f483..3bf446e30e 100644 --- a/ghc/compiler/typecheck/TcForeign.lhs +++ b/ghc/compiler/typecheck/TcForeign.lhs @@ -45,13 +45,15 @@ import TcType ( Type, tcSplitFunTys, tcSplitTyConApp_maybe, import ForeignCall ( CExportSpec(..), CCallTarget(..), CLabelString, isCLabelString, isDynamicTarget, withDNTypes, DNKind(..), DNCallSpec(..) ) -import MachOp ( machRepByteWidth ) import PrelNames ( hasKey, ioTyConKey ) import CmdLineOpts ( dopt_HscLang, HscLang(..) ) import Outputable import SrcLoc ( Located(..), srcSpanStart ) -import Bag ( emptyBag, consBag ) +import Bag ( consBag ) +#if alpha_TARGET_ARCH +import MachOp ( machRepByteWidth ) +#endif \end{code} \begin{code} @@ -200,7 +202,7 @@ checkFEDArgs arg_tys = returnM () tcForeignExports :: [LForeignDecl Name] -> TcM (LHsBinds TcId, [LForeignDecl TcId]) tcForeignExports decls - = foldlM combine (emptyBag, []) (filter isForeignExport decls) + = foldlM combine (emptyLHsBinds, []) (filter isForeignExport decls) where combine (binds, fs) fe = wrapLocSndM tcFExport fe `thenM` \ (b, f) -> diff --git a/ghc/compiler/typecheck/TcGenDeriv.lhs b/ghc/compiler/typecheck/TcGenDeriv.lhs index f812b20961..1e5576728c 100644 --- a/ghc/compiler/typecheck/TcGenDeriv.lhs +++ b/ghc/compiler/typecheck/TcGenDeriv.lhs @@ -32,8 +32,7 @@ import HsSyn import RdrName ( RdrName, mkVarUnqual, getRdrName, mkRdrUnqual, mkDerivedRdrName ) import BasicTypes ( Fixity(..), maxPrecedence, Boxity(..) ) -import FieldLabel ( fieldLabelName ) -import DataCon ( isNullaryDataCon, dataConTag, +import DataCon ( isNullarySrcDataCon, dataConTag, dataConOrigArgTys, dataConSourceArity, fIRST_TAG, DataCon, dataConName, dataConIsInfix, dataConFieldLabels ) @@ -153,7 +152,7 @@ gen_Eq_binds tycon (nullary_cons, nonnullary_cons) | isNewTyCon tycon = ([], tyConDataCons tycon) - | otherwise = partition isNullaryDataCon (tyConDataCons tycon) + | otherwise = partition isNullarySrcDataCon (tyConDataCons tycon) rest = if (null nullary_cons) then @@ -168,7 +167,7 @@ gen_Eq_binds tycon in listToBag [ mk_FunBind tycon_loc eq_RDR ((map pats_etc nonnullary_cons) ++ rest), - mk_easy_FunBind tycon_loc ne_RDR [a_Pat, b_Pat] emptyBag ( + mk_easy_FunBind tycon_loc ne_RDR [a_Pat, b_Pat] emptyLHsBinds ( nlHsApp (nlHsVar not_RDR) (nlHsPar (nlHsVarApps eq_RDR [a_RDR, b_RDR]))) ] where @@ -315,7 +314,7 @@ gen_Ord_binds tycon single_con_type = isSingleton tycon_data_cons (nullary_cons, nonnullary_cons) | isNewTyCon tycon = ([], tyConDataCons tycon) - | otherwise = partition isNullaryDataCon tycon_data_cons + | otherwise = partition isNullarySrcDataCon tycon_data_cons cmp_eq = mk_FunBind tycon_loc cmp_eq_RDR cmp_eq_match cmp_eq_match @@ -418,7 +417,7 @@ gen_Enum_binds tycon occ_nm = getOccString tycon succ_enum - = mk_easy_FunBind tycon_loc succ_RDR [a_Pat] emptyBag $ + = mk_easy_FunBind tycon_loc succ_RDR [a_Pat] emptyLHsBinds $ untag_Expr tycon [(a_RDR, ah_RDR)] $ nlHsIf (nlHsApps eq_RDR [nlHsVar (maxtag_RDR tycon), nlHsVarApps intDataCon_RDR [ah_RDR]]) @@ -428,7 +427,7 @@ gen_Enum_binds tycon nlHsIntLit 1])) pred_enum - = mk_easy_FunBind tycon_loc pred_RDR [a_Pat] emptyBag $ + = mk_easy_FunBind tycon_loc pred_RDR [a_Pat] emptyLHsBinds $ untag_Expr tycon [(a_RDR, ah_RDR)] $ nlHsIf (nlHsApps eq_RDR [nlHsIntLit 0, nlHsVarApps intDataCon_RDR [ah_RDR]]) @@ -438,7 +437,7 @@ gen_Enum_binds tycon nlHsLit (HsInt (-1))])) to_enum - = mk_easy_FunBind tycon_loc toEnum_RDR [a_Pat] emptyBag $ + = mk_easy_FunBind tycon_loc toEnum_RDR [a_Pat] emptyLHsBinds $ nlHsIf (nlHsApps and_RDR [nlHsApps ge_RDR [nlHsVar a_RDR, nlHsIntLit 0], nlHsApps le_RDR [nlHsVar a_RDR, nlHsVar (maxtag_RDR tycon)]]) @@ -446,7 +445,7 @@ gen_Enum_binds tycon (illegal_toEnum_tag occ_nm (maxtag_RDR tycon)) enum_from - = mk_easy_FunBind tycon_loc enumFrom_RDR [a_Pat] emptyBag $ + = mk_easy_FunBind tycon_loc enumFrom_RDR [a_Pat] emptyLHsBinds $ untag_Expr tycon [(a_RDR, ah_RDR)] $ nlHsApps map_RDR [nlHsVar (tag2con_RDR tycon), @@ -455,7 +454,7 @@ gen_Enum_binds tycon (nlHsVar (maxtag_RDR tycon)))] enum_from_then - = mk_easy_FunBind tycon_loc enumFromThen_RDR [a_Pat, b_Pat] emptyBag $ + = mk_easy_FunBind tycon_loc enumFromThen_RDR [a_Pat, b_Pat] emptyLHsBinds $ untag_Expr tycon [(a_RDR, ah_RDR), (b_RDR, bh_RDR)] $ nlHsApp (nlHsVarApps map_RDR [tag2con_RDR tycon]) $ nlHsPar (enum_from_then_to_Expr @@ -468,7 +467,7 @@ gen_Enum_binds tycon )) from_enum - = mk_easy_FunBind tycon_loc fromEnum_RDR [a_Pat] emptyBag $ + = mk_easy_FunBind tycon_loc fromEnum_RDR [a_Pat] emptyLHsBinds $ untag_Expr tycon [(a_RDR, ah_RDR)] $ (nlHsVarApps intDataCon_RDR [ah_RDR]) \end{code} @@ -582,7 +581,7 @@ gen_Ix_binds tycon enum_range = mk_easy_FunBind tycon_loc range_RDR - [nlTuplePat [a_Pat, b_Pat] Boxed] emptyBag $ + [nlTuplePat [a_Pat, b_Pat] Boxed] emptyLHsBinds $ untag_Expr tycon [(a_RDR, ah_RDR)] $ untag_Expr tycon [(b_RDR, bh_RDR)] $ nlHsApp (nlHsVarApps map_RDR [tag2con_RDR tycon]) $ @@ -594,7 +593,7 @@ gen_Ix_binds tycon = mk_easy_FunBind tycon_loc index_RDR [noLoc (AsPat (noLoc c_RDR) (nlTuplePat [a_Pat, nlWildPat] Boxed)), - d_Pat] emptyBag ( + d_Pat] emptyLHsBinds ( nlHsIf (nlHsPar (nlHsVarApps inRange_RDR [c_RDR, d_RDR])) ( untag_Expr tycon [(a_RDR, ah_RDR)] ( untag_Expr tycon [(d_RDR, dh_RDR)] ( @@ -611,7 +610,7 @@ gen_Ix_binds tycon enum_inRange = mk_easy_FunBind tycon_loc inRange_RDR - [nlTuplePat [a_Pat, b_Pat] Boxed, c_Pat] emptyBag ( + [nlTuplePat [a_Pat, b_Pat] Boxed, c_Pat] emptyLHsBinds ( untag_Expr tycon [(a_RDR, ah_RDR)] ( untag_Expr tycon [(b_RDR, bh_RDR)] ( untag_Expr tycon [(c_RDR, ch_RDR)] ( @@ -645,7 +644,7 @@ gen_Ix_binds tycon -------------------------------------------------------------- single_con_range = mk_easy_FunBind tycon_loc range_RDR - [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed] emptyBag $ + [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed] emptyLHsBinds $ nlHsDo ListComp stmts where stmts = zipWith3Equal "single_con_range" mk_qual as_needed bs_needed cs_needed @@ -676,7 +675,7 @@ gen_Ix_binds tycon range_size = mk_easy_FunBind tycon_loc rangeSize_RDR - [nlTuplePat [a_Pat, b_Pat] Boxed] emptyBag ( + [nlTuplePat [a_Pat, b_Pat] Boxed] emptyLHsBinds ( genOpApp ( (nlHsApps index_RDR [nlTuple [a_Expr, b_Expr] Boxed, b_Expr]) @@ -687,7 +686,7 @@ gen_Ix_binds tycon = mk_easy_FunBind tycon_loc inRange_RDR [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed, con_pat cs_needed] - emptyBag ( + emptyLHsBinds ( foldl1 and_Expr (zipWith3Equal "single_con_inRange" in_range as_needed bs_needed cs_needed)) where in_range a b c = nlHsApps inRange_RDR [nlTuple [nlHsVar a, nlHsVar b] Boxed, @@ -752,7 +751,7 @@ gen_Read_binds get_fixity tycon loc = getSrcSpan tycon data_cons = tyConDataCons tycon - (nullary_cons, non_nullary_cons) = partition isNullaryDataCon data_cons + (nullary_cons, non_nullary_cons) = partition isNullarySrcDataCon data_cons read_prec = mkVarBind loc readPrec_RDR (nlHsApp (nlHsVar parens_RDR) read_cons) @@ -844,7 +843,7 @@ gen_Read_binds get_fixity tycon bindLex (symbol_pat lbl_lit), read_punc ")"] where - lbl_str = occNameUserString (getOccName (fieldLabelName lbl)) + lbl_str = occNameUserString (getOccName lbl) lbl_lit = mkHsString lbl_str is_id_start c = isAlpha c || c == '_' \end{code} @@ -928,7 +927,7 @@ gen_Show_binds get_fixity tycon -- lexeme. Only the space after the '=' is necessary, but -- it seems tidier to have them both sides. where - occ_nm = getOccName (fieldLabelName l) + occ_nm = getOccName l nm = occNameUserString_with_parens occ_nm show_args = zipWith show_arg bs_needed arg_tys @@ -1006,7 +1005,7 @@ gen_Typeable_binds tycon = unitBag $ mk_easy_FunBind tycon_loc (mk_typeOf_RDR tycon) -- Name of appropriate type0f function - [nlWildPat] emptyBag + [nlWildPat] emptyLHsBinds (nlHsApps mkTypeRep_RDR [tycon_rep, nlList []]) where tycon_loc = getSrcSpan tycon @@ -1112,7 +1111,7 @@ gen_Data_binds fix_env tycon tycon_loc dataTypeOf_RDR [nlWildPat] - emptyBag + emptyLHsBinds (nlHsVar data_type_name) ------------ $dT @@ -1141,7 +1140,7 @@ gen_Data_binds fix_env tycon nlList labels, -- Field labels nlHsVar fixity] -- Fixity where - labels = map (nlHsLit . mkHsString . getOccString . fieldLabelName) + labels = map (nlHsLit . mkHsString . getOccString) (dataConFieldLabels dc) dc_occ = getOccName dc is_infix = isDataSymOcc dc_occ @@ -1342,9 +1341,8 @@ eq_Expr tycon ty a b = genOpApp a eq_op b where eq_op | not (isUnLiftedType ty) = eq_RDR - | otherwise = + | otherwise = primOpRdrName (assoc_ty_id "Eq" tycon eq_op_tbl ty) -- we have to do something special for primitive things... - primOpRdrName (assoc_ty_id "Eq" tycon eq_op_tbl ty) \end{code} \begin{code} diff --git a/ghc/compiler/typecheck/TcHsSyn.lhs b/ghc/compiler/typecheck/TcHsSyn.lhs index 349bd25c18..30b70362da 100644 --- a/ghc/compiler/typecheck/TcHsSyn.lhs +++ b/ghc/compiler/typecheck/TcHsSyn.lhs @@ -8,7 +8,6 @@ checker. \begin{code} module TcHsSyn ( - TcDictBinds, mkHsTyApp, mkHsDictApp, mkHsConApp, mkHsTyLam, mkHsDictLam, mkHsLet, mkHsApp, hsLitType, hsPatType, mkHsAppTy, mkSimpleHsAlt, @@ -21,7 +20,7 @@ module TcHsSyn ( idCoercion, isIdCoercion, -- re-exported from TcMonad - TcId, TcIdSet, + TcId, TcIdSet, TcDictBinds, zonkTopDecls, zonkTopExpr, zonkTopLExpr, zonkId, zonkTopBndrs @@ -37,11 +36,11 @@ import Id ( idType, setIdType, Id ) import TcRnMonad import Type ( Type ) -import TcType ( TcType, TcTyVar, mkTyVarTy, tcGetTyVar, mkTyConApp ) +import TcType ( TcType, TcTyVar, mkTyVarTy, tcGetTyVar, mkTyConApp, isImmutableTyVar ) import Kind ( isLiftedTypeKind, liftedTypeKind, isSubKind ) import qualified Type -import TcMType ( zonkTcTyVarToTyVar, zonkType, zonkTcType, zonkTcTyVars, - putTcTyVar ) +import TcMType ( zonkQuantifiedTyVar, zonkType, zonkTcType, zonkTcTyVars, + putMetaTyVar ) import TysPrim ( charPrimTy, intPrimTy, floatPrimTy, doublePrimTy, addrPrimTy ) @@ -64,11 +63,6 @@ import Outputable \end{code} -\begin{code} -type TcDictBinds = LHsBinds TcId -- Bag of dictionary bindings -\end{code} - - %************************************************************************ %* * \subsection[mkFailurePair]{Code for pattern-matching and other failures} @@ -81,20 +75,21 @@ then something is wrong. hsPatType :: OutPat Id -> Type hsPatType pat = pat_type (unLoc pat) -pat_type (ParPat pat) = hsPatType pat -pat_type (WildPat ty) = ty -pat_type (VarPat var) = idType var -pat_type (LazyPat pat) = hsPatType pat -pat_type (LitPat lit) = hsLitType lit -pat_type (AsPat var pat) = idType (unLoc var) -pat_type (ListPat _ ty) = mkListTy ty -pat_type (PArrPat _ ty) = mkPArrTy ty -pat_type (TuplePat pats box) = mkTupleTy box (length pats) (map hsPatType pats) -pat_type (ConPatOut _ _ ty _ _) = ty -pat_type (SigPatOut _ ty _) = ty -pat_type (NPatOut lit ty _) = ty -pat_type (NPlusKPatOut id _ _ _) = idType (unLoc id) -pat_type (DictPat ds ms) = case (ds ++ ms) of +pat_type (ParPat pat) = hsPatType pat +pat_type (WildPat ty) = ty +pat_type (VarPat var) = idType var +pat_type (VarPatOut var _) = idType var +pat_type (LazyPat pat) = hsPatType pat +pat_type (LitPat lit) = hsLitType lit +pat_type (AsPat var pat) = idType (unLoc var) +pat_type (ListPat _ ty) = mkListTy ty +pat_type (PArrPat _ ty) = mkPArrTy ty +pat_type (TuplePat pats box) = mkTupleTy box (length pats) (map hsPatType pats) +pat_type (ConPatOut _ _ _ _ _ ty) = ty +pat_type (SigPatOut pat ty) = ty +pat_type (NPatOut lit ty _) = ty +pat_type (NPlusKPatOut id _ _ _) = idType (unLoc id) +pat_type (DictPat ds ms) = case (ds ++ ms) of [] -> unitTy [d] -> idType d ds -> mkTupleTy Boxed (length ds) (map idType ds) @@ -190,11 +185,15 @@ extendZonkEnv :: ZonkEnv -> [Id] -> ZonkEnv extendZonkEnv (ZonkEnv zonk_ty env) ids = ZonkEnv zonk_ty (extendVarEnvList env [(id,id) | id <- ids]) +extendZonkEnv1 :: ZonkEnv -> Id -> ZonkEnv +extendZonkEnv1 (ZonkEnv zonk_ty env) id + = ZonkEnv zonk_ty (extendVarEnv env id id) + setZonkType :: ZonkEnv -> (TcType -> TcM Type) -> ZonkEnv setZonkType (ZonkEnv _ env) zonk_ty = ZonkEnv zonk_ty env -mkZonkEnv :: [Id] -> ZonkEnv -mkZonkEnv ids = extendZonkEnv emptyZonkEnv ids +zonkEnvIds :: ZonkEnv -> [Id] +zonkEnvIds (ZonkEnv _ env) = varEnvElts env zonkIdOcc :: ZonkEnv -> TcId -> Id -- Ids defined in this module should be in the envt; @@ -238,34 +237,25 @@ zonkTopExpr e = zonkExpr emptyZonkEnv e zonkTopLExpr :: LHsExpr TcId -> TcM (LHsExpr Id) zonkTopLExpr e = zonkLExpr emptyZonkEnv e -zonkTopDecls :: Bag (LHsBind TcId) -> [LRuleDecl TcId] -> [LForeignDecl TcId] +zonkTopDecls :: LHsBinds TcId -> [LRuleDecl TcId] -> [LForeignDecl TcId] -> TcM ([Id], Bag (LHsBind Id), [LForeignDecl Id], [LRuleDecl Id]) -zonkTopDecls binds rules fords -- Top level is implicitly recursive - = fixM (\ ~(new_ids, _, _, _) -> - let - zonk_env = mkZonkEnv new_ids - in - zonkMonoBinds zonk_env binds `thenM` \ binds' -> - zonkRules zonk_env rules `thenM` \ rules' -> - zonkForeignExports zonk_env fords `thenM` \ fords' -> - - returnM (collectHsBindBinders binds', binds', fords', rules') - ) +zonkTopDecls binds rules fords + = do { (env, binds') <- zonkRecMonoBinds emptyZonkEnv binds + -- Top level is implicitly recursive + ; rules' <- zonkRules env rules + ; fords' <- zonkForeignExports env fords + ; return (zonkEnvIds env, binds', fords', rules') } --------------------------------------------- zonkGroup :: ZonkEnv -> HsBindGroup TcId -> TcM (ZonkEnv, HsBindGroup Id) zonkGroup env (HsBindGroup bs sigs is_rec) = ASSERT( null sigs ) - do { (env1, bs') <- fixM (\ ~(_, new_binds) -> do - { let env1 = extendZonkEnv env (collectHsBindBinders new_binds) - ; bs' <- zonkMonoBinds env1 bs - ; return (env1, bs') }) - ; return (env1, HsBindGroup bs' [] is_rec) } + do { (env1, bs') <- zonkRecMonoBinds env bs + ; return (env1, HsBindGroup bs' [] is_rec) } - zonkGroup env (HsIPBinds binds) = mappM (wrapLocM zonk_ip_bind) binds `thenM` \ new_binds -> let @@ -286,14 +276,22 @@ zonkNestedBinds env (b:bs) = do { (env1, b') <- zonkGroup env b ; return (env2, b':bs') } --------------------------------------------- -zonkMonoBinds :: ZonkEnv -> Bag (LHsBind TcId) -> TcM (Bag (LHsBind Id)) +zonkRecMonoBinds :: ZonkEnv -> LHsBinds TcId -> TcM (ZonkEnv, LHsBinds Id) +zonkRecMonoBinds env binds + = fixM (\ ~(_, new_binds) -> do + { let env1 = extendZonkEnv env (collectHsBindBinders new_binds) + ; binds' <- zonkMonoBinds env1 binds + ; return (env1, binds') }) + +zonkMonoBinds :: ZonkEnv -> LHsBinds TcId -> TcM (LHsBinds Id) zonkMonoBinds env binds = mapBagM (wrapLocM (zonk_bind env)) binds zonk_bind :: ZonkEnv -> HsBind TcId -> TcM (HsBind Id) -zonk_bind env (PatBind pat grhss) - = zonkPat env pat `thenM` \ (new_pat, _) -> - zonkGRHSs env grhss `thenM` \ new_grhss -> - returnM (PatBind new_pat new_grhss) +zonk_bind env (PatBind pat grhss ty) + = do { (_env, new_pat) <- zonkPat env pat -- Env already extended + ; new_grhss <- zonkGRHSs env grhss + ; new_ty <- zonkTcTypeToType env ty + ; return (PatBind new_pat new_grhss new_ty) } zonk_bind env (VarBind var expr) = zonkIdBndr env var `thenM` \ new_var -> @@ -302,35 +300,27 @@ zonk_bind env (VarBind var expr) zonk_bind env (FunBind var inf ms) = wrapLocM (zonkIdBndr env) var `thenM` \ new_var -> - mappM (zonkMatch env) ms `thenM` \ new_ms -> + zonkMatchGroup env ms `thenM` \ new_ms -> returnM (FunBind new_var inf new_ms) zonk_bind env (AbsBinds tyvars dicts exports inlines val_binds) - = mappM zonkTcTyVarToTyVar tyvars `thenM` \ new_tyvars -> - -- No need to extend tyvar env: the effects are - -- propagated through binding the tyvars themselves - + = ASSERT( all isImmutableTyVar tyvars ) zonkIdBndrs env dicts `thenM` \ new_dicts -> fixM (\ ~(new_val_binds, _) -> let - env1 = extendZonkEnv (extendZonkEnv env new_dicts) + env1 = extendZonkEnv (extendZonkEnv env new_dicts) (collectHsBindBinders new_val_binds) in zonkMonoBinds env1 val_binds `thenM` \ new_val_binds -> mappM (zonkExport env1) exports `thenM` \ new_exports -> returnM (new_val_binds, new_exports) ) `thenM` \ (new_val_bind, new_exports) -> - returnM (AbsBinds new_tyvars new_dicts new_exports inlines new_val_bind) + returnM (AbsBinds tyvars new_dicts new_exports inlines new_val_bind) where zonkExport env (tyvars, global, local) - = zonkTcTyVars tyvars `thenM` \ tys -> - let - new_tyvars = map (tcGetTyVar "zonkExport") tys - -- This isn't the binding occurrence of these tyvars - -- but they should *be* tyvars. Hence tcGetTyVar. - in + = ASSERT( all isImmutableTyVar tyvars ) zonkIdBndr env global `thenM` \ new_global -> - returnM (new_tyvars, new_global, zonkIdOcc env local) + returnM (tyvars, new_global, zonkIdOcc env local) \end{code} %************************************************************************ @@ -340,17 +330,22 @@ zonk_bind env (AbsBinds tyvars dicts exports inlines val_binds) %************************************************************************ \begin{code} -zonkMatch :: ZonkEnv -> LMatch TcId-> TcM (LMatch Id) +zonkMatchGroup :: ZonkEnv -> MatchGroup TcId-> TcM (MatchGroup Id) +zonkMatchGroup env (MatchGroup ms ty) + = do { ms' <- mapM (zonkMatch env) ms + ; ty' <- zonkTcTypeToType env ty + ; return (MatchGroup ms' ty') } +zonkMatch :: ZonkEnv -> LMatch TcId-> TcM (LMatch Id) zonkMatch env (L loc (Match pats _ grhss)) - = zonkPats env pats `thenM` \ (new_pats, new_ids) -> - zonkGRHSs (extendZonkEnv env (bagToList new_ids)) grhss `thenM` \ new_grhss -> - returnM (L loc (Match new_pats Nothing new_grhss)) + = do { (env1, new_pats) <- zonkPats env pats + ; new_grhss <- zonkGRHSs env1 grhss + ; return (L loc (Match new_pats Nothing new_grhss)) } ------------------------------------------------------------------------- zonkGRHSs :: ZonkEnv -> GRHSs TcId -> TcM (GRHSs Id) -zonkGRHSs env (GRHSs grhss binds ty) +zonkGRHSs env (GRHSs grhss binds) = zonkNestedBinds env binds `thenM` \ (new_env, new_binds) -> let zonk_grhs (GRHS guarded) @@ -358,8 +353,7 @@ zonkGRHSs env (GRHSs grhss binds ty) returnM (GRHS new_guarded) in mappM (wrapLocM zonk_grhs) grhss `thenM` \ new_grhss -> - zonkTcTypeToType env ty `thenM` \ new_ty -> - returnM (GRHSs new_grhss new_binds new_ty) + returnM (GRHSs new_grhss new_binds) \end{code} %************************************************************************ @@ -388,12 +382,11 @@ zonkExpr env (HsLit (HsRat f ty)) zonkExpr env (HsLit lit) = returnM (HsLit lit) - -- HsOverLit doesn't appear in typechecker output -zonkExpr env (HsLam match) - = zonkMatch env match `thenM` \ new_match -> - returnM (HsLam new_match) +zonkExpr env (HsLam matches) + = zonkMatchGroup env matches `thenM` \ new_matches -> + returnM (HsLam new_matches) zonkExpr env (HsApp e1 e2) = zonkLExpr env e1 `thenM` \ new_e1 -> @@ -432,9 +425,10 @@ zonkExpr env (SectionR op expr) zonkLExpr env expr `thenM` \ new_expr -> returnM (SectionR new_op new_expr) +-- gaw 2004 zonkExpr env (HsCase expr ms) = zonkLExpr env expr `thenM` \ new_expr -> - mappM (zonkMatch env) ms `thenM` \ new_ms -> + zonkMatchGroup env ms `thenM` \ new_ms -> returnM (HsCase new_expr new_ms) zonkExpr env (HsIf e1 e2 e3) @@ -510,11 +504,9 @@ zonkExpr env (HsCoreAnn lbl expr) returnM (HsCoreAnn lbl new_expr) zonkExpr env (TyLam tyvars expr) - = mappM zonkTcTyVarToTyVar tyvars `thenM` \ new_tyvars -> - -- No need to extend tyvar env; see AbsBinds - + = ASSERT( all isImmutableTyVar tyvars ) zonkLExpr env expr `thenM` \ new_expr -> - returnM (TyLam new_tyvars new_expr) + returnM (TyLam tyvars new_expr) zonkExpr env (TyApp expr tys) = zonkLExpr env expr `thenM` \ new_expr -> @@ -535,12 +527,9 @@ zonkExpr env (DictApp expr dicts) -- arrow notation extensions zonkExpr env (HsProc pat body) - = zonkPat env pat `thenM` \ (new_pat, new_ids) -> - let - env1 = extendZonkEnv env (bagToList new_ids) - in - zonkCmdTop env1 body `thenM` \ new_body -> - returnM (HsProc new_pat new_body) + = do { (env1, new_pat) <- zonkPat env pat + ; new_body <- zonkCmdTop env1 body + ; return (HsProc new_pat new_body) } zonkExpr env (HsArrApp e1 e2 ty ho rl) = zonkLExpr env e1 `thenM` \ new_e1 -> @@ -650,13 +639,9 @@ zonkStmt env (LetStmt binds) returnM (env1, LetStmt new_binds) zonkStmt env (BindStmt pat expr) - = zonkLExpr env expr `thenM` \ new_expr -> - zonkPat env pat `thenM` \ (new_pat, new_ids) -> - let - env1 = extendZonkEnv env (bagToList new_ids) - in - returnM (env1, BindStmt new_pat new_expr) - + = do { new_expr <- zonkLExpr env expr + ; (env1, new_pat) <- zonkPat env pat + ; return (env1, BindStmt new_pat new_expr) } ------------------------------------------------------------------------- @@ -683,106 +668,105 @@ mapIPNameTc f (Linear n) = f n `thenM` \ r -> returnM (Linear r) %************************************************************************ \begin{code} -zonkPat :: ZonkEnv -> OutPat TcId -> TcM (OutPat Id, Bag Id) -zonkPat env pat = wrapLocFstM (zonk_pat env) pat +zonkPat :: ZonkEnv -> OutPat TcId -> TcM (ZonkEnv, OutPat Id) +-- Extend the environment as we go, because it's possible for one +-- pattern to bind something that is used in another (inside or +-- to the right) +zonkPat env pat = wrapLocSndM (zonk_pat env) pat zonk_pat env (ParPat p) - = zonkPat env p `thenM` \ (new_p, ids) -> - returnM (ParPat new_p, ids) + = do { (env', p') <- zonkPat env p + ; return (env', ParPat p') } zonk_pat env (WildPat ty) - = zonkTcTypeToType env ty `thenM` \ new_ty -> - returnM (WildPat new_ty, emptyBag) + = do { ty' <- zonkTcTypeToType env ty + ; return (env, WildPat ty') } zonk_pat env (VarPat v) - = zonkIdBndr env v `thenM` \ new_v -> - returnM (VarPat new_v, unitBag new_v) + = do { v' <- zonkIdBndr env v + ; return (extendZonkEnv1 env v', VarPat v') } + +zonk_pat env (VarPatOut v binds) + = do { v' <- zonkIdBndr env v + ; (env', binds') <- zonkRecMonoBinds (extendZonkEnv1 env v') binds + ; returnM (env', VarPatOut v' binds') } zonk_pat env (LazyPat pat) - = zonkPat env pat `thenM` \ (new_pat, ids) -> - returnM (LazyPat new_pat, ids) + = do { (env', pat') <- zonkPat env pat + ; return (env', LazyPat pat') } -zonk_pat env (AsPat n pat) - = wrapLocM (zonkIdBndr env) n `thenM` \ new_n -> - zonkPat env pat `thenM` \ (new_pat, ids) -> - returnM (AsPat new_n new_pat, unLoc new_n `consBag` ids) +zonk_pat env (AsPat (L loc v) pat) + = do { v' <- zonkIdBndr env v + ; (env', pat') <- zonkPat (extendZonkEnv1 env v') pat + ; return (env', AsPat (L loc v') pat') } zonk_pat env (ListPat pats ty) - = zonkTcTypeToType env ty `thenM` \ new_ty -> - zonkPats env pats `thenM` \ (new_pats, ids) -> - returnM (ListPat new_pats new_ty, ids) + = do { ty' <- zonkTcTypeToType env ty + ; (env', pats') <- zonkPats env pats + ; return (env', ListPat pats' ty') } zonk_pat env (PArrPat pats ty) - = zonkTcTypeToType env ty `thenM` \ new_ty -> - zonkPats env pats `thenM` \ (new_pats, ids) -> - returnM (PArrPat new_pats new_ty, ids) + = do { ty' <- zonkTcTypeToType env ty + ; (env', pats') <- zonkPats env pats + ; return (env', PArrPat pats' ty') } zonk_pat env (TuplePat pats boxed) - = zonkPats env pats `thenM` \ (new_pats, ids) -> - returnM (TuplePat new_pats boxed, ids) + = do { (env', pats') <- zonkPats env pats + ; return (env', TuplePat pats' boxed) } -zonk_pat env (ConPatOut n stuff ty tvs dicts) - = zonkTcTypeToType env ty `thenM` \ new_ty -> - mappM zonkTcTyVarToTyVar tvs `thenM` \ new_tvs -> - zonkIdBndrs env dicts `thenM` \ new_dicts -> - let - env1 = extendZonkEnv env new_dicts - in - zonkConStuff env1 stuff `thenM` \ (new_stuff, ids) -> - returnM (ConPatOut n new_stuff new_ty new_tvs new_dicts, - listToBag new_dicts `unionBags` ids) +zonk_pat env (ConPatOut n tvs dicts binds stuff ty) + = ASSERT( all isImmutableTyVar tvs ) + do { new_ty <- zonkTcTypeToType env ty + ; new_dicts <- zonkIdBndrs env dicts + ; let env1 = extendZonkEnv env new_dicts + ; (env2, new_binds) <- zonkRecMonoBinds env1 binds + ; (env', new_stuff) <- zonkConStuff env2 stuff + ; returnM (env', ConPatOut n tvs new_dicts new_binds new_stuff new_ty) } -zonk_pat env (LitPat lit) = returnM (LitPat lit, emptyBag) +zonk_pat env (LitPat lit) = return (env, LitPat lit) -zonk_pat env (SigPatOut pat ty expr) - = zonkPat env pat `thenM` \ (new_pat, ids) -> - zonkTcTypeToType env ty `thenM` \ new_ty -> - zonkExpr env expr `thenM` \ new_expr -> - returnM (SigPatOut new_pat new_ty new_expr, ids) +zonk_pat env (SigPatOut pat ty) + = do { ty' <- zonkTcTypeToType env ty + ; (env', pat') <- zonkPat env pat + ; return (env', SigPatOut pat' ty') } zonk_pat env (NPatOut lit ty expr) - = zonkTcTypeToType env ty `thenM` \ new_ty -> - zonkExpr env expr `thenM` \ new_expr -> - returnM (NPatOut lit new_ty new_expr, emptyBag) + = do { ty' <- zonkTcTypeToType env ty + ; expr' <- zonkExpr env expr + ; return (env, NPatOut lit ty' expr') } -zonk_pat env (NPlusKPatOut n k e1 e2) - = wrapLocM (zonkIdBndr env) n `thenM` \ new_n -> - zonkExpr env e1 `thenM` \ new_e1 -> - zonkExpr env e2 `thenM` \ new_e2 -> - returnM (NPlusKPatOut new_n k new_e1 new_e2, unitBag (unLoc new_n)) +zonk_pat env (NPlusKPatOut (L loc n) k e1 e2) + = do { n' <- zonkIdBndr env n + ; e1' <- zonkExpr env e1 + ; e2' <- zonkExpr env e2 + ; return (extendZonkEnv1 env n', NPlusKPatOut (L loc n') k e1' e2') } zonk_pat env (DictPat ds ms) - = zonkIdBndrs env ds `thenM` \ new_ds -> - zonkIdBndrs env ms `thenM` \ new_ms -> - returnM (DictPat new_ds new_ms, - listToBag new_ds `unionBags` listToBag new_ms) + = do { ds' <- zonkIdBndrs env ds + ; ms' <- zonkIdBndrs env ms + ; return (extendZonkEnv env (ds' ++ ms'), DictPat ds' ms') } --------------------------- zonkConStuff env (PrefixCon pats) - = zonkPats env pats `thenM` \ (new_pats, ids) -> - returnM (PrefixCon new_pats, ids) + = do { (env', pats') <- zonkPats env pats + ; return (env', PrefixCon pats') } zonkConStuff env (InfixCon p1 p2) - = zonkPat env p1 `thenM` \ (new_p1, ids1) -> - zonkPat env p2 `thenM` \ (new_p2, ids2) -> - returnM (InfixCon new_p1 new_p2, ids1 `unionBags` ids2) + = do { (env1, p1') <- zonkPat env p1 + ; (env', p2') <- zonkPat env1 p2 + ; return (env', InfixCon p1' p2') } zonkConStuff env (RecCon rpats) - = mapAndUnzipM zonk_rpat rpats `thenM` \ (new_rpats, ids_s) -> - returnM (RecCon new_rpats, unionManyBags ids_s) + = do { (env', pats') <- zonkPats env pats + ; returnM (env', RecCon (fields `zip` pats')) } where - zonk_rpat (f, pat) - = zonkPat env pat `thenM` \ (new_pat, ids) -> - returnM ((f, new_pat), ids) + (fields, pats) = unzip rpats --------------------------- -zonkPats env [] - = returnM ([], emptyBag) - -zonkPats env (pat:pats) - = zonkPat env pat `thenM` \ (pat', ids1) -> - zonkPats env pats `thenM` \ (pats', ids2) -> - returnM (pat':pats', ids1 `unionBags` ids2) +zonkPats env [] = return (env, []) +zonkPats env (pat:pats) = do { (env1, pat') <- zonkPat env pat + ; (env', pats') <- zonkPats env1 pats + ; return (env', pat':pats') } \end{code} %************************************************************************ @@ -849,7 +833,8 @@ zonkRule env (HsRule name act (vars::[RuleBndr TcId]) lhs rhs) where zonk_bndr (RuleBndr v) | isId (unLoc v) = wrapLocM (zonkIdBndr env) v - | otherwise = wrapLocM zonkTcTyVarToTyVar v + | otherwise = ASSERT( isImmutableTyVar (unLoc v) ) + return v \end{code} @@ -866,10 +851,10 @@ zonkTcTypeToType (ZonkEnv zonk_ty _) ty = zonk_ty ty zonkTypeCollecting :: TcRef TyVarSet -> TcType -> TcM Type -- This variant collects unbound type variables in a mutable variable zonkTypeCollecting unbound_tv_set - = zonkType zonk_unbound_tyvar + = zonkType zonk_unbound_tyvar True where zonk_unbound_tyvar tv - = zonkTcTyVarToTyVar tv `thenM` \ tv' -> + = zonkQuantifiedTyVar tv `thenM` \ tv' -> readMutVar unbound_tv_set `thenM` \ tv_set -> writeMutVar unbound_tv_set (extendVarSet tv_set tv') `thenM_` return (mkTyVarTy tv') @@ -878,7 +863,7 @@ zonkTypeZapping :: TcType -> TcM Type -- This variant is used for everything except the LHS of rules -- It zaps unbound type variables to (), or some other arbitrary type zonkTypeZapping ty - = zonkType zonk_unbound_tyvar ty + = zonkType zonk_unbound_tyvar True ty where -- Zonk a mutable but unbound type variable to an arbitrary type -- We know it's unbound even though we don't carry an environment, @@ -886,7 +871,9 @@ zonkTypeZapping ty -- mutable tyvar to a fresh immutable one. So the mutable store -- plays the role of an environment. If we come across a mutable -- type variable that isn't so bound, it must be completely free. - zonk_unbound_tyvar tv = putTcTyVar tv (mkArbitraryType tv) + zonk_unbound_tyvar tv = do { putMetaTyVar tv ty; return ty } + where + ty = mkArbitraryType tv -- When the type checker finds a type variable with no binding, diff --git a/ghc/compiler/typecheck/TcHsType.lhs b/ghc/compiler/typecheck/TcHsType.lhs index c7e0cbac8c..08effa7c56 100644 --- a/ghc/compiler/typecheck/TcHsType.lhs +++ b/ghc/compiler/typecheck/TcHsType.lhs @@ -10,20 +10,23 @@ module TcHsType ( -- Kind checking kcHsTyVars, kcHsSigType, kcHsLiftedSigType, - kcCheckHsType, kcHsContext, kcHsType, + kcCheckHsType, kcHsContext, kcHsType, -- Typechecking kinded types - tcHsKindedContext, tcHsKindedType, tcTyVarBndrs, dsHsType, + tcHsKindedContext, tcHsKindedType, tcHsBangType, + tcTyVarBndrs, dsHsType, tcLHsConSig, - tcAddScopedTyVars, + tcHsPatSigType, tcAddLetBoundTyVars, - TcSigInfo(..), tcTySig, mkTcSig, maybeSig + TcSigInfo(..), mkTcSig, + TcSigFun, lookupSig ) where #include "HsVersions.h" -import HsSyn ( HsType(..), LHsType, HsTyVarBndr(..), LHsTyVarBndr, - LHsContext, Sig(..), LSig, HsPred(..), LHsPred ) +import HsSyn ( HsType(..), LHsType, HsTyVarBndr(..), LHsTyVarBndr, HsBang, + LHsContext, HsPred(..), LHsPred, LHsBinds, + getBangStrictness, collectSigTysFromHsBinds ) import RnHsSyn ( extractHsTyVars ) import TcHsSyn ( TcId ) @@ -33,31 +36,33 @@ import TcEnv ( tcExtendTyVarEnv, tcExtendKindEnv, TyThing(..), TcTyThing(..), getInLocalScope, wrongThingErr ) -import TcMType ( newKindVar, tcInstType, newMutTyVar, +import TcMType ( newKindVar, tcSkolType, newMetaTyVar, zonkTcKindToKind, checkValidType, UserTypeCtxt(..), pprHsSigCtxt ) import TcUnify ( unifyFunKind, checkExpectedKind ) -import TcType ( Type, PredType(..), ThetaType, TyVarDetails(..), - TcTyVar, TcKind, TcThetaType, TcTauType, - mkTyVarTy, mkTyVarTys, mkFunTy, +import TcType ( Type, PredType(..), ThetaType, + SkolemInfo(SigSkol), MetaDetails(Flexi), + TcType, TcTyVar, TcKind, TcThetaType, TcTauType, + mkTyVarTy, mkFunTy, mkForAllTys, mkFunTys, tcEqType, isPredTy, mkSigmaTy, mkPredTy, mkGenTyConApp, mkTyConApp, mkAppTys, tcSplitFunTy_maybe, tcSplitForAllTys ) import Kind ( liftedTypeKind, ubxTupleKind, openTypeKind, argTypeKind ) -import Inst ( Inst, InstOrigin(..), newMethod, instToId ) +import Inst ( InstOrigin(..) ) -import Id ( mkLocalId, idName, idType ) +import Id ( idName, idType ) import Var ( TyVar, mkTyVar, tyVarKind ) import TyCon ( TyCon, tyConKind ) import Class ( Class, classTyCon ) import Name ( Name ) import NameSet import PrelNames ( genUnitTyConName ) -import Subst ( deShadowTy ) +import Type ( deShadowTy ) import TysWiredIn ( mkListTy, mkPArrTy, mkTupleTy ) +import Bag ( bagToList ) import BasicTypes ( Boxity(..) ) -import SrcLoc ( SrcSpan, Located(..), unLoc, noLoc ) +import SrcLoc ( Located(..), unLoc, noLoc ) import Outputable import List ( nubBy ) \end{code} @@ -197,6 +202,11 @@ tcHsKindedType hs_ty = do { ty <- dsHsType hs_ty ; return (hoistForAllTys ty) } +tcHsBangType :: LHsType Name -> TcM Type +-- Permit a bang, but discard it +tcHsBangType (L span (HsBangTy b ty)) = tcHsKindedType ty +tcHsBangType ty = tcHsKindedType ty + tcHsKindedContext :: LHsContext Name -> TcM ThetaType -- Used when we are expecting a ClassContext (i.e. no implicit params) -- Does not do validity checking, like tcHsKindedType @@ -230,7 +240,7 @@ kcCheckHsType :: LHsType Name -> TcKind -> TcM (LHsType Name) -- Be sure to use checkExpectedKind, rather than simply unifying -- with OpenTypeKind, because it gives better error messages kcCheckHsType (L span ty) exp_kind - = addSrcSpan span $ + = setSrcSpan span $ kc_hs_type ty `thenM` \ (ty', act_kind) -> checkExpectedKind ty act_kind exp_kind `thenM_` returnM (L span ty') @@ -255,9 +265,6 @@ kc_hs_type (HsParTy ty) = kcHsType ty `thenM` \ (ty', kind) -> returnM (HsParTy ty', kind) --- kcHsType (HsSpliceTy s) --- = kcSpliceType s) - kc_hs_type (HsTyVar name) = kcTyVar name `thenM` \ kind -> returnM (HsTyVar name, kind) @@ -324,6 +331,14 @@ kc_hs_type (HsForAllTy exp tv_names context ty) -- kind-checked, so we only allow liftedTypeKind here returnM (HsForAllTy exp tv_names' ctxt' ty', liftedTypeKind) +kc_hs_type (HsBangTy b ty) + = do { (ty', kind) <- kcHsType ty + ; return (HsBangTy b ty', kind) } + +kc_hs_type ty@(HsSpliceTy _) + = failWithTc (ptext SLIT("Unexpected type splice:") <+> ppr ty) + + --------------------------- kcApps :: TcKind -- Function kind -> SDoc -- Function @@ -405,7 +420,8 @@ The type desugarer * Transforms from HsType to Type * Zonks any kinds -It cannot fail, and does no validity checking +It cannot fail, and does no validity checking, except for +structural matters, such as spurious ! annotations. \begin{code} dsHsType :: LHsType Name -> TcM Type @@ -418,6 +434,9 @@ ds_type ty@(HsTyVar name) ds_type (HsParTy ty) -- Remove the parentheses markers = dsHsType ty +ds_type ty@(HsBangTy _ _) -- No bangs should be here + = failWithTc (ptext SLIT("Unexpected strictness annotation:") <+> ppr ty) + ds_type (HsKindSig ty k) = dsHsType ty -- Kind checking done already @@ -441,7 +460,7 @@ ds_type (HsFunTy ty1 ty2) ds_type (HsOpTy ty1 (L span op) ty2) = dsHsType ty1 `thenM` \ tau_ty1 -> dsHsType ty2 `thenM` \ tau_ty2 -> - addSrcSpan span (ds_var_app op [tau_ty1,tau_ty2]) + setSrcSpan span (ds_var_app op [tau_ty1,tau_ty2]) ds_type (HsNumTy n) = ASSERT(n==1) @@ -485,14 +504,15 @@ ds_var_app name arg_tys case thing of ATyVar tv -> returnM (mkAppTys (mkTyVarTy tv) arg_tys) AGlobal (ATyCon tc) -> returnM (mkGenTyConApp tc arg_tys) - AThing _ -> tcLookupTyCon name `thenM` \ tc -> - returnM (mkGenTyConApp tc arg_tys) +-- AThing _ -> tcLookupTyCon name `thenM` \ tc -> +-- returnM (mkGenTyConApp tc arg_tys) other -> pprPanic "ds_app_type" (ppr name <+> ppr arg_tys) \end{code} Contexts ~~~~~~~~ + \begin{code} dsHsLPred :: LHsPred Name -> TcM PredType dsHsLPred pred = dsHsPred (unLoc pred) @@ -507,6 +527,59 @@ dsHsPred (HsIParam name ty) returnM (IParam name arg_ty) \end{code} +GADT constructor signatures + +\begin{code} +tcLHsConSig :: LHsType Name + -> TcM ([TcTyVar], TcThetaType, + [HsBang], [TcType], + TyCon, [TcType]) +-- Take apart the type signature for a data constructor +-- The difference is that there can be bangs at the top of +-- the argument types, and kind-checking is the right place to check +tcLHsConSig sig@(L span (HsForAllTy exp tv_names ctxt ty)) + = setSrcSpan span $ + addErrCtxt (gadtSigCtxt sig) $ + tcTyVarBndrs tv_names $ \ tyvars -> + do { theta <- mappM dsHsLPred (unLoc ctxt) + ; (bangs, arg_tys, tc, res_tys) <- tc_con_sig_tau ty + ; return (tyvars, theta, bangs, arg_tys, tc, res_tys) } +tcLHsConSig ty + = do { (bangs, arg_tys, tc, res_tys) <- tc_con_sig_tau ty + ; return ([], [], bangs, arg_tys, tc, res_tys) } + +-------- +tc_con_sig_tau (L _ (HsFunTy arg ty)) + = do { (bangs, arg_tys, tc, res_tys) <- tc_con_sig_tau ty + ; arg_ty <- tcHsBangType arg + ; return (getBangStrictness arg : bangs, + arg_ty : arg_tys, tc, res_tys) } + +tc_con_sig_tau ty + = do { (tc, res_tys) <- tc_con_res ty [] + ; return ([], [], tc, res_tys) } + +-------- +tc_con_res (L _ (HsAppTy fun res_ty)) res_tys + = do { res_ty' <- dsHsType res_ty + ; tc_con_res fun (res_ty' : res_tys) } + +tc_con_res ty@(L _ (HsTyVar name)) res_tys + = do { thing <- tcLookup name + ; case thing of + AGlobal (ATyCon tc) -> return (tc, res_tys) + other -> failWithTc (badGadtDecl ty) + } + +tc_con_res ty _ = failWithTc (badGadtDecl ty) + +gadtSigCtxt ty + = hang (ptext SLIT("In the signature of a data constructor:")) + 2 (ppr ty) +badGadtDecl ty + = hang (ptext SLIT("Malformed constructor signature:")) + 2 (ppr ty) +\end{code} %************************************************************************ %* * @@ -543,7 +616,7 @@ tcTyVarBndrs bndrs thing_inside where zonk (KindedTyVar name kind) = zonkTcKindToKind kind `thenM` \ kind' -> returnM (mkTyVar name kind') - zonk (UserTyVar name) = pprTrace "BAD: Un-kinded tyvar" (ppr name) $ + zonk (UserTyVar name) = pprTrace "Un-kinded tyvar" (ppr name) $ returnM (mkTyVar name liftedTypeKind) \end{code} @@ -588,46 +661,72 @@ Historical note: it with expected_ty afterwards \begin{code} -tcAddScopedTyVars :: [LHsType Name] -> TcM a -> TcM a -tcAddScopedTyVars [] thing_inside - = thing_inside -- Quick get-out for the empty case - -tcAddScopedTyVars sig_tys thing_inside - = getInLocalScope `thenM` \ in_scope -> - getSrcSpanM `thenM` \ span -> - let - sig_tvs = [ L span (UserTyVar n) - | ty <- sig_tys, - n <- nameSetToList (extractHsTyVars ty), - not (in_scope n) ] - -- The tyvars we want are the free type variables of - -- the type that are not already in scope - in +tcPatSigBndrs :: LHsType Name + -> TcM ([TcTyVar], -- Brought into scope + LHsType Name) -- Kinded, but not yet desugared + +tcPatSigBndrs hs_ty + = do { in_scope <- getInLocalScope + ; span <- getSrcSpanM + ; let sig_tvs = [ L span (UserTyVar n) + | n <- nameSetToList (extractHsTyVars hs_ty), + not (in_scope n) ] + -- The tyvars we want are the free type variables of + -- the type that are not already in scope + -- Behave like kcHsType on a ForAll type -- i.e. make kinded tyvars with mutable kinds, -- and kind-check the enclosed types - kcHsTyVars sig_tvs (\ kinded_tvs -> do - { mappM kcTypeType sig_tys - ; return kinded_tvs }) `thenM` \ kinded_tvs -> + ; (kinded_tvs, kinded_ty) <- kcHsTyVars sig_tvs $ \ kinded_tvs -> do + { kinded_ty <- kcTypeType hs_ty + ; return (kinded_tvs, kinded_ty) } -- Zonk the mutable kinds and bring the tyvars into scope - -- Rather like tcTyVarBndrs, except that it brings *mutable* - -- tyvars into scope, not immutable ones + -- Just like the call to tcTyVarBndrs in ds_type (HsForAllTy case), + -- except that it brings *meta* tyvars into scope, not regular ones -- + -- [Out of date, but perhaps should be resurrected] -- Furthermore, the tyvars are PatSigTvs, which means that we get better -- error messages when type variables escape: -- Inferred type is less polymorphic than expected -- Quantified type variable `t' escapes -- It is mentioned in the environment: -- t is bound by the pattern type signature at tcfail103.hs:6 - mapM (zonk . unLoc) kinded_tvs `thenM` \ tyvars -> - tcExtendTyVarEnv tyvars thing_inside - + ; tyvars <- mapM (zonk . unLoc) kinded_tvs + ; return (tyvars, kinded_ty) } where zonk (KindedTyVar name kind) = zonkTcKindToKind kind `thenM` \ kind' -> - newMutTyVar name kind' PatSigTv - zonk (UserTyVar name) = pprTrace "BAD: Un-kinded tyvar" (ppr name) $ + newMetaTyVar name kind' Flexi + -- Scoped type variables are bound to a *type*, hence Flexi + zonk (UserTyVar name) = pprTrace "Un-kinded tyvar" (ppr name) $ returnM (mkTyVar name liftedTypeKind) + +tcHsPatSigType :: UserTypeCtxt + -> LHsType Name -- The type signature + -> TcM ([TcTyVar], -- Newly in-scope type variables + TcType) -- The signature + +tcHsPatSigType ctxt hs_ty + = addErrCtxt (pprHsSigCtxt ctxt hs_ty) $ + do { (tyvars, kinded_ty) <- tcPatSigBndrs hs_ty + + -- Complete processing of the type, and check its validity + ; tcExtendTyVarEnv tyvars $ do + { sig_ty <- tcHsKindedType kinded_ty + ; checkValidType ctxt sig_ty + ; return (tyvars, sig_ty) } + } + +tcAddLetBoundTyVars :: LHsBinds Name -> TcM a -> TcM a +-- Turgid funciton, used for type variables bound by the patterns of a let binding + +tcAddLetBoundTyVars binds thing_inside + = go (collectSigTysFromHsBinds (bagToList binds)) thing_inside + where + go [] thing_inside = thing_inside + go (hs_ty:hs_tys) thing_inside + = do { (tyvars, _kinded_ty) <- tcPatSigBndrs hs_ty + ; tcExtendTyVarEnv tyvars (go hs_tys thing_inside) } \end{code} @@ -648,46 +747,25 @@ been instantiated. \begin{code} data TcSigInfo - = TySigInfo { - sig_poly_id :: TcId, -- *Polymorphic* binder for this value... - -- Has name = N - - sig_tvs :: [TcTyVar], -- tyvars - sig_theta :: TcThetaType, -- theta - sig_tau :: TcTauType, -- tau - - sig_mono_id :: TcId, -- *Monomorphic* binder for this value - -- Does *not* have name = N - -- Has type tau - - sig_insts :: [Inst], -- Empty if theta is null, or - -- (method mono_id) otherwise - - sig_loc :: SrcSpan -- The location of the signature + = TcSigInfo { + sig_id :: TcId, -- *Polymorphic* binder for this value... + sig_tvs :: [TcTyVar], -- tyvars + sig_theta :: TcThetaType, -- theta + sig_tau :: TcTauType, -- tau + sig_loc :: InstLoc -- The location of the signature } +type TcSigFun = Name -> Maybe TcSigInfo instance Outputable TcSigInfo where - ppr (TySigInfo id tyvars theta tau _ inst _) = - ppr id <+> ptext SLIT("::") <+> ppr tyvars <+> ppr theta <+> ptext SLIT("=>") <+> ppr tau - -maybeSig :: [TcSigInfo] -> Name -> Maybe (TcSigInfo) - -- Search for a particular signature -maybeSig [] name = Nothing -maybeSig (sig@(TySigInfo sig_id _ _ _ _ _ _) : sigs) name - | name == idName sig_id = Just sig - | otherwise = maybeSig sigs name -\end{code} + ppr (TcSigInfo { sig_id = id, sig_tvs = tyvars, sig_theta = theta, sig_tau = tau}) + = ppr id <+> ptext SLIT("::") <+> ppr tyvars <+> ppr theta <+> ptext SLIT("=>") <+> ppr tau - -\begin{code} -tcTySig :: LSig Name -> TcM TcSigInfo - -tcTySig (L span (Sig (L _ v) ty)) - = addSrcSpan span $ - tcHsSigType (FunSigCtxt v) ty `thenM` \ sigma_tc_ty -> - mkTcSig (mkLocalId v sigma_tc_ty) `thenM` \ sig -> - returnM sig +lookupSig :: [TcSigInfo] -> TcSigFun -- Search for a particular signature +lookupSig [] name = Nothing +lookupSig (sig : sigs) name + | name == idName (sig_id sig) = Just sig + | otherwise = lookupSig sigs name mkTcSig :: TcId -> TcM TcSigInfo mkTcSig poly_id @@ -698,20 +776,11 @@ mkTcSig poly_id -- the tyvars *do* get unified with something, we want to carry on -- typechecking the rest of the program with the function bound -- to a pristine type, namely sigma_tc_ty - tcInstType SigTv (idType poly_id) `thenM` \ (tyvars', theta', tau') -> - - getInstLoc SignatureOrigin `thenM` \ inst_loc -> - newMethod inst_loc poly_id - (mkTyVarTys tyvars') - theta' tau' `thenM` \ inst -> - -- We make a Method even if it's not overloaded; no harm - -- But do not extend the LIE! We're just making an Id. - - getSrcSpanM `thenM` \ src_loc -> - returnM (TySigInfo { sig_poly_id = poly_id, sig_tvs = tyvars', - sig_theta = theta', sig_tau = tau', - sig_mono_id = instToId inst, - sig_insts = [inst], sig_loc = src_loc }) + do { let rigid_info = SigSkol (idName poly_id) + ; (tyvars', theta', tau') <- tcSkolType rigid_info (idType poly_id) + ; loc <- getInstLoc (SigOrigin rigid_info) + ; return (TcSigInfo { sig_id = poly_id, sig_tvs = tyvars', + sig_theta = theta', sig_tau = tau', sig_loc = loc }) } \end{code} diff --git a/ghc/compiler/typecheck/TcInstDcls.lhs b/ghc/compiler/typecheck/TcInstDcls.lhs index 2be85609e6..4a22f9c6a3 100644 --- a/ghc/compiler/typecheck/TcInstDcls.lhs +++ b/ghc/compiler/typecheck/TcInstDcls.lhs @@ -13,28 +13,28 @@ import TcBinds ( tcSpecSigs ) import TcClassDcl ( tcMethodBind, mkMethodBind, badMethodErr, tcClassDecl2, getGenericInstances ) import TcRnMonad -import TcMType ( tcInstType, checkValidTheta, checkValidInstHead, instTypeErr, +import TcMType ( tcSkolType, checkValidTheta, checkValidInstHead, instTypeErr, checkAmbiguity, SourceTyCtxt(..) ) -import TcType ( mkClassPred, tcSplitForAllTys, tyVarsOfType, +import TcType ( mkClassPred, tcSplitForAllTys, tyVarsOfType, tcSplitSigmaTy, getClassPredTys, tcSplitPredTy_maybe, mkTyVarTys, - TyVarDetails(..), tcSplitDFunTy, pprClassPred ) + SkolemInfo(InstSkol), tcSplitDFunTy, pprClassPred ) import Inst ( tcInstClassOp, newDicts, instToId, showLIE, tcExtendLocalInstEnv ) import TcDeriv ( tcDeriving ) import TcEnv ( tcExtendGlobalValEnv, tcExtendTyVarEnv2, InstInfo(..), InstBindings(..), - newDFunName, tcExtendLocalValEnv + newDFunName, tcExtendIdEnv ) import TcHsType ( kcHsSigType, tcHsKindedType ) import TcUnify ( checkSigTyVars ) import TcSimplify ( tcSimplifyCheck, tcSimplifyTop ) -import Subst ( mkTyVarSubst, substTheta, substTy ) +import Type ( zipTvSubst, substTheta, substTys ) import DataCon ( classDataCon ) import Class ( classBigSig ) import Var ( Id, idName, idType ) import MkId ( mkDictFunId, rUNTIME_ERROR_ID ) import FunDeps ( checkInstFDs ) import Name ( Name, getSrcLoc ) -import NameSet ( unitNameSet, emptyNameSet, nameSetToList, unionNameSets ) +import NameSet ( unitNameSet, emptyNameSet, unionNameSets ) import UnicodeUtil ( stringToUtf8 ) import Maybe ( catMaybes ) import SrcLoc ( srcLocSpan, unLoc, noLoc, Located(..), srcSpanStart ) @@ -186,7 +186,7 @@ tcLocalInstDecl1 :: LInstDecl Name tcLocalInstDecl1 decl@(L loc (InstDecl poly_ty binds uprags)) = -- Prime error recovery, set source location recoverM (returnM Nothing) $ - addSrcSpan loc $ + setSrcSpan loc $ addErrCtxt (instDeclCtxt1 poly_ty) $ -- Typecheck the instance type itself. We can't use @@ -227,7 +227,7 @@ tcInstDecls2 tycl_decls inst_decls = do { -- (a) Default methods from class decls (dm_binds_s, dm_ids_s) <- mapAndUnzipM tcClassDecl2 $ filter (isClassDecl.unLoc) tycl_decls - ; tcExtendLocalValEnv (concat dm_ids_s) $ do + ; tcExtendIdEnv (concat dm_ids_s) $ do -- (b) instance declarations ; inst_binds_s <- mappM tcInstDecl2 inst_decls @@ -310,10 +310,11 @@ tcInstDecl2 :: InstInfo -> TcM (LHsBinds Id) tcInstDecl2 (InstInfo { iDFunId = dfun_id, iBinds = binds }) = -- Prime error recovery - recoverM (returnM emptyBag) $ - addSrcSpan (srcLocSpan (getSrcLoc dfun_id)) $ + recoverM (returnM emptyLHsBinds) $ + setSrcSpan (srcLocSpan (getSrcLoc dfun_id)) $ addErrCtxt (instDeclCtxt2 (idType dfun_id)) $ let + rigid_info = InstSkol dfun_id inst_ty = idType dfun_id (inst_tyvars, _) = tcSplitForAllTys inst_ty -- The tyvars of the instance decl scope over the 'where' part @@ -322,18 +323,18 @@ tcInstDecl2 (InstInfo { iDFunId = dfun_id, iBinds = binds }) in -- Instantiate the instance decl with tc-style type variables - tcInstType InstTv inst_ty `thenM` \ (inst_tyvars', dfun_theta', inst_head') -> + tcSkolType rigid_info inst_ty `thenM` \ (inst_tyvars', dfun_theta', inst_head') -> let Just pred = tcSplitPredTy_maybe inst_head' (clas, inst_tys') = getClassPredTys pred (class_tyvars, sc_theta, _, op_items) = classBigSig clas -- Instantiate the super-class context with inst_tys - sc_theta' = substTheta (mkTyVarSubst class_tyvars inst_tys') sc_theta - origin = InstanceDeclOrigin + sc_theta' = substTheta (zipTvSubst class_tyvars inst_tys') sc_theta + origin = SigOrigin rigid_info in -- Create dictionary Ids from the specified instance contexts. - newDicts origin sc_theta' `thenM` \ sc_dicts -> + newDicts InstScOrigin sc_theta' `thenM` \ sc_dicts -> newDicts origin dfun_theta' `thenM` \ dfun_arg_dicts -> newDicts origin [pred] `thenM` \ [this_dict] -> -- Default-method Ids may be mentioned in synthesised RHSs, @@ -344,13 +345,16 @@ tcInstDecl2 (InstInfo { iDFunId = dfun_id, iBinds = binds }) let -- These insts are in scope; quite a few, eh? avail_insts = [this_dict] ++ dfun_arg_dicts ++ sc_dicts in - tcMethods clas inst_tyvars inst_tyvars' + tcMethods origin clas inst_tyvars inst_tyvars' dfun_theta' inst_tys' avail_insts op_items binds `thenM` \ (meth_ids, meth_binds) -> -- Figure out bindings for the superclass context tcSuperClasses inst_tyvars' dfun_arg_dicts sc_dicts - `thenM` \ (zonked_inst_tyvars, sc_binds_inner, sc_binds_outer) -> + `thenM` \ (sc_binds_inner, sc_binds_outer) -> + + -- It's possible that the superclass stuff might have done unification + checkSigTyVars inst_tyvars' `thenM_` -- Deal with 'SPECIALISE instance' pragmas by making them -- look like SPECIALISE pragmas for the dfun @@ -413,10 +417,10 @@ tcInstDecl2 (InstInfo { iDFunId = dfun_id, iBinds = binds }) all_binds = dict_bind `consBag` (sc_binds_inner `unionBags` meth_binds) main_bind = noLoc $ AbsBinds - zonked_inst_tyvars - (map instToId dfun_arg_dicts) - [(inst_tyvars', dfun_id, this_dict_id)] - inlines all_binds + inst_tyvars' + (map instToId dfun_arg_dicts) + [(inst_tyvars', dfun_id, this_dict_id)] + inlines all_binds in showLIE (text "instance") `thenM_` returnM (unitBag main_bind `unionBags` @@ -424,7 +428,7 @@ tcInstDecl2 (InstInfo { iDFunId = dfun_id, iBinds = binds }) sc_binds_outer) -tcMethods clas inst_tyvars inst_tyvars' dfun_theta' inst_tys' +tcMethods origin clas inst_tyvars inst_tyvars' dfun_theta' inst_tys' avail_insts op_items (VanillaInst monobinds uprags) = -- Check that all the method bindings come from this class let @@ -435,7 +439,7 @@ tcMethods clas inst_tyvars inst_tyvars' dfun_theta' inst_tys' -- Make the method bindings let - mk_method_bind = mkMethodBind InstanceDeclOrigin clas inst_tys' monobinds + mk_method_bind = mkMethodBind origin clas inst_tys' monobinds in mapAndUnzipM mk_method_bind op_items `thenM` \ (meth_insts, meth_infos) -> @@ -472,17 +476,18 @@ tcMethods clas inst_tyvars inst_tyvars' dfun_theta' inst_tys' all_insts = avail_insts ++ catMaybes meth_insts xtve = inst_tyvars `zip` inst_tyvars' tc_method_bind = tcMethodBind xtve inst_tyvars' dfun_theta' all_insts uprags + meth_ids = [meth_id | (_,meth_id,_) <- meth_infos] in + mapM tc_method_bind meth_infos `thenM` \ meth_binds_s -> - returnM ([meth_id | (_,meth_id,_) <- meth_infos], - unionManyBags meth_binds_s) + returnM (meth_ids, unionManyBags meth_binds_s) -- Derived newtype instances -tcMethods clas inst_tyvars inst_tyvars' dfun_theta' inst_tys' +tcMethods origin clas inst_tyvars inst_tyvars' dfun_theta' inst_tys' avail_insts op_items (NewTypeDerived rep_tys) - = getInstLoc InstanceDeclOrigin `thenM` \ inst_loc -> + = getInstLoc origin `thenM` \ inst_loc -> mapAndUnzip3M (do_one inst_loc) op_items `thenM` \ (meth_ids, meth_binds, rhs_insts) -> tcSimplifyCheck @@ -507,8 +512,8 @@ tcMethods clas inst_tyvars inst_tyvars' dfun_theta' inst_tys' return (meth_id, noLoc (VarBind meth_id (nlHsVar (instToId rhs_inst))), rhs_inst) -- Instantiate rep_tys with the relevant type variables - rep_tys' = map (substTy subst) rep_tys - subst = mkTyVarSubst inst_tyvars (mkTyVarTys inst_tyvars') + rep_tys' = substTys subst rep_tys + subst = zipTvSubst inst_tyvars (mkTyVarTys inst_tyvars') \end{code} Note: [Superclass loops] @@ -559,15 +564,12 @@ tcSuperClasses inst_tyvars' dfun_arg_dicts sc_dicts dfun_arg_dicts sc_dicts) `thenM` \ (sc_binds1, sc_lie) -> - -- It's possible that the superclass stuff might have done unification - checkSigTyVars inst_tyvars' `thenM` \ zonked_inst_tyvars -> - -- We must simplify this all the way down -- lest we build superclass loops -- See Note [Superclass loops] above tcSimplifyTop sc_lie `thenM` \ sc_binds2 -> - returnM (zonked_inst_tyvars, sc_binds1, sc_binds2) + returnM (sc_binds1, sc_binds2) where doc = ptext SLIT("instance declaration superclass context") diff --git a/ghc/compiler/typecheck/TcMType.lhs b/ghc/compiler/typecheck/TcMType.lhs index da5429480f..a444842855 100644 --- a/ghc/compiler/typecheck/TcMType.lhs +++ b/ghc/compiler/typecheck/TcMType.lhs @@ -11,30 +11,30 @@ module TcMType ( -------------------------------- -- Creating new mutable type variables - newTyVar, newSigTyVar, - newTyVarTy, -- Kind -> TcM TcType - newTyVarTys, -- Int -> Kind -> TcM [TcType] + newFlexiTyVar, + newTyFlexiVarTy, -- Kind -> TcM TcType + newTyFlexiVarTys, -- Int -> Kind -> TcM [TcType] newKindVar, newKindVars, - putTcTyVar, getTcTyVar, - newMutTyVar, readMutTyVar, writeMutTyVar, + lookupTcTyVar, condLookupTcTyVar, LookupTyVarResult(..), + newMetaTyVar, readMetaTyVar, writeMetaTyVar, putMetaTyVar, -------------------------------- -- Instantiation tcInstTyVar, tcInstTyVars, tcInstType, + tcSkolTyVar, tcSkolTyVars, tcSkolType, -------------------------------- -- Checking type validity Rank, UserTypeCtxt(..), checkValidType, pprHsSigCtxt, SourceTyCtxt(..), checkValidTheta, checkFreeness, checkValidInstHead, instTypeErr, checkAmbiguity, - arityErr, + arityErr, isRigidType, -------------------------------- -- Zonking - zonkType, - zonkTcTyVar, zonkTcTyVars, zonkTcTyVarsAndFV, + zonkType, zonkTcPredType, + zonkTcTyVar, zonkTcTyVars, zonkTcTyVarsAndFV, zonkQuantifiedTyVar, zonkTcType, zonkTcTypes, zonkTcClassConstraints, zonkTcThetaType, - zonkTcPredType, zonkTcTyVarToTyVar, zonkTcKindToKind, zonkTcKind, readKindVar, writeKindVar @@ -50,33 +50,35 @@ import TypeRep ( Type(..), PredType(..), TyNote(..), -- Friend; can see repres Kind, ThetaType ) import TcType ( TcType, TcThetaType, TcTauType, TcPredType, - TcTyVarSet, TcKind, TcTyVar, TyVarDetails(..), + TcTyVarSet, TcKind, TcTyVar, TcTyVarDetails(..), + MetaDetails(..), SkolemInfo(..), isMetaTyVar, metaTvRef, tcEqType, tcCmpPred, isClassPred, tcSplitPhiTy, tcSplitPredTy_maybe, tcSplitAppTy_maybe, tcSplitTyConApp_maybe, tcSplitForAllTys, tcIsTyVarTy, tcSplitSigmaTy, tcIsTyVarTy, - isUnLiftedType, isIPPred, - typeKind, + isUnLiftedType, isIPPred, isImmutableTyVar, + typeKind, isFlexi, isSkolemTyVar, mkAppTy, mkTyVarTy, mkTyVarTys, tyVarsOfPred, getClassPredTys_maybe, tyVarsOfType, tyVarsOfTypes, pprPred, pprTheta, pprClassPred ) -import Kind ( Kind(..), KindVar(..), mkKindVar, +import Kind ( Kind(..), KindVar(..), mkKindVar, isSubKind, isLiftedTypeKind, isArgTypeKind, isOpenTypeKind, - liftedTypeKind + liftedTypeKind, defaultKind ) -import Subst ( Subst, mkTopTyVarSubst, substTy ) +import Type ( TvSubst, zipTopTvSubst, substTy ) import Class ( Class, classArity, className ) import TyCon ( TyCon, isSynTyCon, isUnboxedTupleTyCon, tyConArity, tyConName ) import Var ( TyVar, tyVarKind, tyVarName, isTyVar, - mkTyVar, mkTcTyVar, tcTyVarRef, isTcTyVar ) + mkTyVar, mkTcTyVar, tcTyVarDetails, isTcTyVar ) -- others: import TcRnMonad -- TcType, amongst others import FunDeps ( grow ) import Name ( Name, setNameUnique, mkSysTvName ) import VarSet +import VarEnv import CmdLineOpts ( dopt, DynFlag(..) ) import Util ( nOfThem, isSingleton, equalLength, notNull ) import ListSetOps ( removeDups ) @@ -92,34 +94,47 @@ import Outputable %************************************************************************ \begin{code} -newMutTyVar :: Name -> Kind -> TyVarDetails -> TcM TyVar -newMutTyVar name kind details - = do { ref <- newMutVar Nothing ; - return (mkTcTyVar name kind details ref) } +newMetaTyVar :: Name -> Kind -> MetaDetails -> TcM TyVar +newMetaTyVar name kind details + = do { ref <- newMutVar details ; + return (mkTcTyVar name kind (MetaTv ref)) } -readMutTyVar :: TyVar -> TcM (Maybe Type) -readMutTyVar tyvar = readMutVar (tcTyVarRef tyvar) +readMetaTyVar :: TyVar -> TcM MetaDetails +readMetaTyVar tyvar = ASSERT2( isMetaTyVar tyvar, ppr tyvar ) + readMutVar (metaTvRef tyvar) -writeMutTyVar :: TyVar -> Maybe Type -> TcM () -writeMutTyVar tyvar val = writeMutVar (tcTyVarRef tyvar) val +writeMetaTyVar :: TyVar -> MetaDetails -> TcM () +writeMetaTyVar tyvar val = ASSERT2( isMetaTyVar tyvar, ppr tyvar ) + writeMutVar (metaTvRef tyvar) val -newTyVar :: Kind -> TcM TcTyVar -newTyVar kind +newFlexiTyVar :: Kind -> TcM TcTyVar +newFlexiTyVar kind = newUnique `thenM` \ uniq -> - newMutTyVar (mkSysTvName uniq FSLIT("t")) kind VanillaTv + newMetaTyVar (mkSysTvName uniq FSLIT("t")) kind Flexi -newSigTyVar :: Kind -> TcM TcTyVar -newSigTyVar kind - = newUnique `thenM` \ uniq -> - newMutTyVar (mkSysTvName uniq FSLIT("s")) kind SigTv - -newTyVarTy :: Kind -> TcM TcType -newTyVarTy kind - = newTyVar kind `thenM` \ tc_tyvar -> +newTyFlexiVarTy :: Kind -> TcM TcType +newTyFlexiVarTy kind + = newFlexiTyVar kind `thenM` \ tc_tyvar -> returnM (TyVarTy tc_tyvar) -newTyVarTys :: Int -> Kind -> TcM [TcType] -newTyVarTys n kind = mappM newTyVarTy (nOfThem n kind) +newTyFlexiVarTys :: Int -> Kind -> TcM [TcType] +newTyFlexiVarTys n kind = mappM newTyFlexiVarTy (nOfThem n kind) + +isRigidType :: TcType -> TcM Bool +-- Check that the type is rigid, *taking the type refinement into account* +-- In other words if a rigid type variable tv is refined to a wobbly type, +-- the answer should be False +-- ToDo: can this happen? +isRigidType ty + = do { rigids <- mapM is_rigid (varSetElems (tyVarsOfType ty)) + ; return (and rigids) } + where + is_rigid tv = do { details <- lookupTcTyVar tv + ; case details of + RigidTv -> return True + IndirectTv True ty -> isRigidType ty + other -> return False + } newKindVar :: TcM TcKind newKindVar = do { uniq <- newUnique @@ -139,38 +154,38 @@ newKindVars n = mappM (\ _ -> newKindVar) (nOfThem n ()) Instantiating a bunch of type variables -\begin{code} -tcInstTyVars :: TyVarDetails -> [TyVar] - -> TcM ([TcTyVar], [TcType], Subst) +Note [TyVarName] +~~~~~~~~~~~~~~~~ +Note that we don't change the print-name +This won't confuse the type checker but there's a chance +that two different tyvars will print the same way +in an error message. -dppr-debug will show up the difference +Better watch out for this. If worst comes to worst, just +use mkSystemName. -tcInstTyVars tv_details tyvars - = mappM (tcInstTyVar tv_details) tyvars `thenM` \ tc_tyvars -> - let - tys = mkTyVarTys tc_tyvars - in - returnM (tc_tyvars, tys, mkTopTyVarSubst tyvars tys) + +\begin{code} +----------------------- +tcInstTyVars :: [TyVar] -> TcM ([TcTyVar], [TcType], TvSubst) +tcInstTyVars tyvars + = do { tc_tvs <- mappM tcInstTyVar tyvars + ; let tys = mkTyVarTys tc_tvs + ; returnM (tc_tvs, tys, zipTopTvSubst tyvars tys) } -- Since the tyvars are freshly made, -- they cannot possibly be captured by - -- any existing for-alls. Hence mkTopTyVarSubst - -tcInstTyVar tv_details tyvar - = newUnique `thenM` \ uniq -> - let - name = setNameUnique (tyVarName tyvar) uniq - -- Note that we don't change the print-name - -- This won't confuse the type checker but there's a chance - -- that two different tyvars will print the same way - -- in an error message. -dppr-debug will show up the difference - -- Better watch out for this. If worst comes to worst, just - -- use mkSystemName. - in - newMutTyVar name (tyVarKind tyvar) tv_details + -- any existing for-alls. Hence zipTopTvSubst + +tcInstTyVar tyvar + = do { uniq <- newUnique + ; let name = setNameUnique (tyVarName tyvar) uniq + -- See Note [TyVarName] + ; newMetaTyVar name (tyVarKind tyvar) Flexi } -tcInstType :: TyVarDetails -> TcType -> TcM ([TcTyVar], TcThetaType, TcType) +tcInstType :: TcType -> TcM ([TcTyVar], TcThetaType, TcType) -- tcInstType instantiates the outer-level for-alls of a TcType with -- fresh (mutable) type variables, splits off the dictionary part, -- and returns the pieces. -tcInstType tv_details ty +tcInstType ty = case tcSplitForAllTys ty of ([], rho) -> -- There may be overloading despite no type variables; -- (?x :: Int) => Int -> Int @@ -179,11 +194,40 @@ tcInstType tv_details ty in returnM ([], theta, tau) - (tyvars, rho) -> tcInstTyVars tv_details tyvars `thenM` \ (tyvars', _, tenv) -> + (tyvars, rho) -> tcInstTyVars tyvars `thenM` \ (tyvars', _, tenv) -> let (theta, tau) = tcSplitPhiTy (substTy tenv rho) in returnM (tyvars', theta, tau) + +--------------------------------------------- +-- Similar functions but for skolem constants + +tcSkolTyVars :: SkolemInfo -> [TyVar] -> TcM [TcTyVar] +tcSkolTyVars info tyvars = mappM (tcSkolTyVar info) tyvars + +tcSkolTyVar :: SkolemInfo -> TyVar -> TcM TcTyVar +tcSkolTyVar info tyvar + = do { uniq <- newUnique + ; let name = setNameUnique (tyVarName tyvar) uniq + -- See Note [TyVarName] + ; return (mkTcTyVar name (tyVarKind tyvar) + (SkolemTv info)) } + +tcSkolType :: SkolemInfo -> TcType -> TcM ([TcTyVar], TcThetaType, TcType) +tcSkolType info ty + = case tcSplitForAllTys ty of + ([], rho) -> let + (theta, tau) = tcSplitPhiTy rho + in + returnM ([], theta, tau) + + (tyvars, rho) -> tcSkolTyVars info tyvars `thenM` \ tyvars' -> + let + tenv = zipTopTvSubst tyvars (mkTyVarTys tyvars') + (theta, tau) = tcSplitPhiTy (substTy tenv rho) + in + returnM (tyvars', theta, tau) \end{code} @@ -194,30 +238,26 @@ tcInstType tv_details ty %************************************************************************ \begin{code} -putTcTyVar :: TcTyVar -> TcType -> TcM TcType -getTcTyVar :: TcTyVar -> TcM (Maybe TcType) -\end{code} - -Putting is easy: - -\begin{code} -putTcTyVar tyvar ty - | not (isTcTyVar tyvar) +putMetaTyVar :: TcTyVar -> TcType -> TcM () +#ifndef DEBUG +putMetaTyVar tyvar ty = writeMetaTyVar tyvar (Indirect ty) +#else +putMetaTyVar tyvar ty + | not (isMetaTyVar tyvar) = pprTrace "putTcTyVar" (ppr tyvar) $ - returnM ty + returnM () | otherwise - = ASSERT( isTcTyVar tyvar ) - writeMutTyVar tyvar (Just ty) `thenM_` - returnM ty + = ASSERT( isMetaTyVar tyvar ) + ASSERT2( k2 `isSubKind` k1, (ppr tyvar <+> ppr k1) $$ (ppr ty <+> ppr k2) ) + do { ASSERTM( do { details <- readMetaTyVar tyvar; return (isFlexi details) } ) + ; writeMetaTyVar tyvar (Indirect ty) } + where + k1 = tyVarKind tyvar + k2 = typeKind ty +#endif \end{code} -Getting is more interesting. The easy thing to do is just to read, thus: - -\begin{verbatim} -getTcTyVar tyvar = readMutTyVar tyvar -\end{verbatim} - But it's more fun to short out indirections on the way: If this version returns a TyVar, then that TyVar is unbound. If it returns any other type, then there might be bound TyVars embedded inside it. @@ -225,6 +265,49 @@ any other type, then there might be bound TyVars embedded inside it. We return Nothing iff the original box was unbound. \begin{code} +data LookupTyVarResult -- The result of a lookupTcTyVar call + = FlexiTv + | RigidTv + | IndirectTv Bool TcType + -- True => This is a non-wobbly type refinement, + -- gotten from GADT match unification + -- False => This is a wobbly type, + -- gotten from inference unification + +lookupTcTyVar :: TcTyVar -> TcM LookupTyVarResult +-- This function is the ONLY PLACE that we consult the +-- type refinement carried by the monad +-- +-- The boolean returned with Indirect +lookupTcTyVar tyvar + = case tcTyVarDetails tyvar of + SkolemTv _ -> do { type_reft <- getTypeRefinement + ; case lookupVarEnv type_reft tyvar of + Just ty -> return (IndirectTv True ty) + Nothing -> return RigidTv + } + MetaTv ref -> do { details <- readMutVar ref + ; case details of + Indirect ty -> return (IndirectTv False ty) + Flexi -> return FlexiTv + } + +-- Look up a meta type variable, conditionally consulting +-- the current type refinement +condLookupTcTyVar :: Bool -> TcTyVar -> TcM LookupTyVarResult +condLookupTcTyVar use_refinement tyvar + | use_refinement = lookupTcTyVar tyvar + | otherwise + = case tcTyVarDetails tyvar of + SkolemTv _ -> return RigidTv + MetaTv ref -> do { details <- readMutVar ref + ; case details of + Indirect ty -> return (IndirectTv False ty) + Flexi -> return FlexiTv + } + +{- +-- gaw 2004 We aren't shorting anything out anymore, at least for now getTcTyVar tyvar | not (isTcTyVar tyvar) = pprTrace "getTcTyVar" (ppr tyvar) $ @@ -232,10 +315,10 @@ getTcTyVar tyvar | otherwise = ASSERT2( isTcTyVar tyvar, ppr tyvar ) - readMutTyVar tyvar `thenM` \ maybe_ty -> + readMetaTyVar tyvar `thenM` \ maybe_ty -> case maybe_ty of Just ty -> short_out ty `thenM` \ ty' -> - writeMutTyVar tyvar (Just ty') `thenM_` + writeMetaTyVar tyvar (Just ty') `thenM_` returnM (Just ty') Nothing -> returnM Nothing @@ -246,15 +329,16 @@ short_out ty@(TyVarTy tyvar) = returnM ty | otherwise - = readMutTyVar tyvar `thenM` \ maybe_ty -> + = readMetaTyVar tyvar `thenM` \ maybe_ty -> case maybe_ty of Just ty' -> short_out ty' `thenM` \ ty' -> - writeMutTyVar tyvar (Just ty') `thenM_` + writeMetaTyVar tyvar (Just ty') `thenM_` returnM ty' other -> returnM ty short_out other_ty = returnM other_ty +-} \end{code} @@ -275,14 +359,14 @@ zonkTcTyVarsAndFV tyvars = mappM zonkTcTyVar tyvars `thenM` \ tys -> returnM (tyVarsOfTypes tys) zonkTcTyVar :: TcTyVar -> TcM TcType -zonkTcTyVar tyvar = zonkTyVar (\ tv -> returnM (TyVarTy tv)) tyvar +zonkTcTyVar tyvar = zonkTyVar (\ tv -> returnM (TyVarTy tv)) True tyvar \end{code} ----------------- Types \begin{code} zonkTcType :: TcType -> TcM TcType -zonkTcType ty = zonkType (\ tv -> returnM (TyVarTy tv)) ty +zonkTcType ty = zonkType (\ tv -> returnM (TyVarTy tv)) True ty zonkTcTypes :: [TcType] -> TcM [TcType] zonkTcTypes tys = mappM zonkTcType tys @@ -308,37 +392,38 @@ zonkTcPredType (IParam n t) are used at the end of type checking \begin{code} --- zonkTcTyVarToTyVar is applied to the *binding* occurrence --- of a type variable, at the *end* of type checking. It changes --- the *mutable* type variable into an *immutable* one. --- --- It does this by making an immutable version of tv and binds tv to it. --- Now any bound occurences of the original type variable will get --- zonked to the immutable version. - -zonkTcTyVarToTyVar :: TcTyVar -> TcM TyVar -zonkTcTyVarToTyVar tv - = let - -- Make an immutable version, defaulting - -- the kind to lifted if necessary - immut_tv = mkTyVar (tyVarName tv) (tyVarKind tv) - -- was: defaultKind (tyVarKind tv), but I don't - immut_tv_ty = mkTyVarTy immut_tv - - zap tv = putTcTyVar tv immut_tv_ty - -- Bind the mutable version to the immutable one - in - -- If the type variable is mutable, then bind it to immut_tv_ty - -- so that all other occurrences of the tyvar will get zapped too - zonkTyVar zap tv `thenM` \ ty2 -> - - -- This warning shows up if the allegedly-unbound tyvar is - -- already bound to something. It can actually happen, and - -- in a harmless way (see [Silly Type Synonyms] below) so - -- it's only a warning - WARN( not (immut_tv_ty `tcEqType` ty2), ppr tv $$ ppr immut_tv $$ ppr ty2 ) - - returnM immut_tv +zonkQuantifiedTyVar :: TcTyVar -> TcM TyVar +-- zonkQuantifiedTyVar is applied to the a TcTyVar when quantifying over it. +-- It might be a meta TyVar, in which case we freeze it inot ano ordinary TyVar. +-- When we do this, we also default the kind -- see notes with Kind.defaultKind +-- The meta tyvar is updated to point to the new regular TyVar. Now any +-- bound occurences of the original type variable will get zonked to +-- the immutable version. +-- +-- We leave skolem TyVars alone; they are imutable. +zonkQuantifiedTyVar tv + | isSkolemTyVar tv = return tv + -- It might be a skolem type variable, + -- for example from a user type signature + + | otherwise -- It's a meta-type-variable + = do { details <- readMetaTyVar tv + + -- Create the new, frozen, regular type variable + ; let final_kind = defaultKind (tyVarKind tv) + final_tv = mkTyVar (tyVarName tv) final_kind + + -- Bind the meta tyvar to the new tyvar + ; case details of + Indirect ty -> WARN( True, ppr tv $$ ppr ty ) + return () + -- [Sept 04] I don't think this should happen + -- See note [Silly Type Synonym] + + other -> writeMetaTyVar tv (Indirect (mkTyVarTy final_tv)) + + -- Return the new tyvar + ; return final_tv } \end{code} [Silly Type Synonyms] @@ -366,10 +451,15 @@ Consider this: * So we get a dict binding for Num (C d a), which is zonked to give a = () + [Note Sept 04: now that we are zonking quantified type variables + on construction, the 'a' will be frozen as a regular tyvar on + quantification, so the floated dict will still have type (C d a). + Which renders this whole note moot; happily!] * Then the /\a abstraction has a zonked 'a' in it. -All very silly. I think its harmless to ignore the problem. +All very silly. I think its harmless to ignore the problem. We'll end up with +a /\a in the final result but all the occurrences of a will be zonked to () %************************************************************************ @@ -387,9 +477,10 @@ All very silly. I think its harmless to ignore the problem. zonkType :: (TcTyVar -> TcM Type) -- What to do with unbound mutable type variables -- see zonkTcType, and zonkTcTypeToType - -> TcType + -> Bool -- Should we consult the current type refinement? + -> TcType -> TcM Type -zonkType unbound_var_fn ty +zonkType unbound_var_fn rflag ty = go ty where go (TyConApp tycon tys) = mappM go tys `thenM` \ tys' -> @@ -419,11 +510,11 @@ zonkType unbound_var_fn ty -- to pull the TyConApp to the top. -- The two interesting cases! - go (TyVarTy tyvar) = zonkTyVar unbound_var_fn tyvar + go (TyVarTy tyvar) = zonkTyVar unbound_var_fn rflag tyvar - go (ForAllTy tyvar ty) = zonkTcTyVarToTyVar tyvar `thenM` \ tyvar' -> - go ty `thenM` \ ty' -> - returnM (ForAllTy tyvar' ty') + go (ForAllTy tyvar ty) = ASSERT( isImmutableTyVar tyvar ) + go ty `thenM` \ ty' -> + returnM (ForAllTy tyvar ty') go_pred (ClassP c tys) = mappM go tys `thenM` \ tys' -> returnM (ClassP c tys') @@ -431,19 +522,23 @@ zonkType unbound_var_fn ty returnM (IParam n ty') zonkTyVar :: (TcTyVar -> TcM Type) -- What to do for an unbound mutable variable - -> TcTyVar -> TcM TcType -zonkTyVar unbound_var_fn tyvar - | not (isTcTyVar tyvar) -- Not a mutable tyvar. This can happen when + -> Bool -- Consult the type refinement? + -> TcTyVar -> TcM TcType +zonkTyVar unbound_var_fn rflag tyvar + | not (isTcTyVar tyvar) -- This can happen when -- zonking a forall type, when the bound type variable -- needn't be mutable - = ASSERT( isTyVar tyvar ) -- Should not be any immutable kind vars - returnM (TyVarTy tyvar) + = returnM (TyVarTy tyvar) | otherwise - = getTcTyVar tyvar `thenM` \ maybe_ty -> - case maybe_ty of - Nothing -> unbound_var_fn tyvar -- Mutable and unbound - Just other_ty -> zonkType unbound_var_fn other_ty -- Bound + = condLookupTcTyVar rflag tyvar `thenM` \ details -> + case details of + -- If b is true, the variable was refined, and therefore it is okay + -- to continue refining inside. Otherwise it was wobbly and we should + -- not refine further inside. + IndirectTv b ty -> zonkType unbound_var_fn b ty -- Bound flexi/refined rigid + FlexiTv -> unbound_var_fn tyvar -- Unbound flexi + RigidTv -> return (TyVarTy tyvar) -- Rigid, no zonking necessary \end{code} diff --git a/ghc/compiler/typecheck/TcMatches.hi-boot-6 b/ghc/compiler/typecheck/TcMatches.hi-boot-6 index 25d13a53e7..057eea1026 100644 --- a/ghc/compiler/typecheck/TcMatches.hi-boot-6 +++ b/ghc/compiler/typecheck/TcMatches.hi-boot-6 @@ -5,6 +5,6 @@ tcGRHSsPat :: HsExpr.GRHSs Name.Name -> TcRnTypes.TcM (HsExpr.GRHSs Var.Id) tcMatchesFun :: Name.Name - -> [HsExpr.LMatch Name.Name] + -> HsExpr.MatchGroup Name.Name -> TcUnify.Expected TcType.TcType - -> TcRnTypes.TcM [HsExpr.LMatch Var.Id] + -> TcRnTypes.TcM (HsExpr.MatchGroup Var.Id) diff --git a/ghc/compiler/typecheck/TcMatches.lhs b/ghc/compiler/typecheck/TcMatches.lhs index 76933c4fc0..6f7c6956d8 100644 --- a/ghc/compiler/typecheck/TcMatches.lhs +++ b/ghc/compiler/typecheck/TcMatches.lhs @@ -13,40 +13,38 @@ module TcMatches ( tcMatchesFun, tcGRHSsPat, tcMatchesCase, tcMatchLambda, #include "HsVersions.h" -import {-# SOURCE #-} TcExpr( tcCheckRho, tcMonoExpr ) +import {-# SOURCE #-} TcExpr( tcCheckRho, tcInferRho, tcMonoExpr ) -import HsSyn ( HsExpr(..), LHsExpr, HsBindGroup(..), +import HsSyn ( HsExpr(..), LHsExpr, MatchGroup(..), Match(..), LMatch, GRHSs(..), GRHS(..), Stmt(..), LStmt, HsMatchContext(..), HsStmtContext(..), ReboundNames, LPat, pprMatch, isDoExpr, pprMatchContext, pprStmtContext, pprStmtResultContext, - collectSigTysFromPats, glueBindsOnGRHSs + collectPatsBinders, glueBindsOnGRHSs ) -import TcHsSyn ( ExprCoFn, TcDictBinds, isIdCoercion, (<$>), (<.>) ) +import TcHsSyn ( ExprCoFn, isIdCoercion, (<$>), (<.>) ) import TcRnMonad -import TcHsType ( tcAddScopedTyVars, tcHsSigType, UserTypeCtxt(..) ) +import TcHsType ( tcHsPatSigType, UserTypeCtxt(..) ) import Inst ( tcSyntaxName, tcInstCall ) -import TcEnv ( TcId, tcLookupLocalIds, tcLookupId, tcExtendLocalValEnv, tcExtendLocalValEnv2 ) -import TcPat ( tcPat, tcMonoPatBndr ) -import TcMType ( newTyVarTy, newTyVarTys, zonkTcType ) -import TcType ( TcType, TcTyVar, TcSigmaType, TcRhoType, - tyVarsOfTypes, tidyOpenTypes, isSigmaTy, typeKind, - mkFunTy, isOverloadedTy, liftedTypeKind, openTypeKind, - mkArrowKind, mkAppTy ) +import TcEnv ( TcId, tcLookupLocalIds, tcLookupId, tcExtendIdEnv, + tcExtendTyVarEnv ) +import TcPat ( PatCtxt(..), tcPats ) +import TcMType ( newTyFlexiVarTy, newTyFlexiVarTys, zonkTcType, isRigidType ) +import TcType ( TcType, TcTyVar, TcSigmaType, TcRhoType, mkFunTys, + tyVarsOfTypes, tidyOpenTypes, isSigmaTy, mkTyConApp, + liftedTypeKind, openTypeKind, mkArrowKind, mkAppTy ) import TcBinds ( tcBindsAndThen ) -import TcUnify ( Expected(..), newHole, zapExpectedType, zapExpectedBranches, readExpectedType, - unifyTauTy, subFunTys, unifyPArrTy, unifyListTy, unifyFunTy, - checkSigTyVarsWrt, tcSubExp, tcGen ) -import TcSimplify ( tcSimplifyCheck, bindInstsOfLocalFuns ) +import TcUnify ( Expected(..), zapExpectedType, readExpectedType, + unifyTauTy, subFunTys, unifyListTy, unifyTyConApp, + checkSigTyVarsWrt, zapExpectedBranches, tcSubExp, tcGen, + unifyAppTy ) import Name ( Name ) -import TysWiredIn ( boolTy, mkListTy, mkPArrTy ) +import TysWiredIn ( boolTy, parrTyCon, listTyCon ) import Id ( idType, mkLocalId ) import CoreFVs ( idFreeTyVars ) -import BasicTypes ( RecFlag(..) ) import VarSet -import Bag import Util ( isSingleton, notNull ) import Outputable import SrcLoc ( Located(..), noLoc ) @@ -67,26 +65,30 @@ same number of arguments before using @tcMatches@ to do the work. \begin{code} tcMatchesFun :: Name - -> [LMatch Name] - -> Expected TcRhoType -- Expected type - -> TcM [LMatch TcId] - -tcMatchesFun fun_name matches@(first_match:_) expected_ty - = -- Check that they all have the same no of arguments - -- Location is in the monad, set the caller so that - -- any inter-equation error messages get some vaguely - -- sensible location. Note: we have to do this odd - -- ann-grabbing, because we don't always have annotations in - -- hand when we call tcMatchesFun... - checkTc (sameNoOfArgs matches) - (varyingArgsErr fun_name matches) `thenM_` + -> MatchGroup Name + -> Expected TcRhoType -- Expected type of function + -> TcM (MatchGroup TcId) -- Returns type of body + +tcMatchesFun fun_name matches exp_ty + = do { -- Check that they all have the same no of arguments + -- Location is in the monad, set the caller so that + -- any inter-equation error messages get some vaguely + -- sensible location. Note: we have to do this odd + -- ann-grabbing, because we don't always have annotations in + -- hand when we call tcMatchesFun... + checkTc (sameNoOfArgs matches) (varyingArgsErr fun_name matches) -- ToDo: Don't use "expected" stuff if there ain't a type signature -- because inconsistency between branches -- may show up as something wrong with the (non-existent) type signature - -- No need to zonk expected_ty, because subFunTys does that on the fly - tcMatches match_ctxt matches expected_ty + -- This is one of two places places we call subFunTys + -- The point is that if expected_y is a "hole", we want + -- to make pat_tys and rhs_ty as "holes" too. + ; exp_ty' <- zapExpectedBranches matches exp_ty + ; subFunTys matches exp_ty' $ \ pat_tys rhs_ty -> + tcMatches match_ctxt pat_tys rhs_ty matches + } where match_ctxt = MC { mc_what = FunRhs fun_name, mc_body = tcMonoExpr } @@ -97,29 +99,19 @@ parser guarantees that each equation has exactly one argument. \begin{code} tcMatchesCase :: TcMatchCtxt -- Case context - -> [LMatch Name] -- The case alternatives + -> TcRhoType -- Type of scrutinee + -> MatchGroup Name -- The case alternatives -> Expected TcRhoType -- Type of whole case expressions - -> TcM (TcRhoType, -- Inferred type of the scrutinee - [LMatch TcId]) -- Translated alternatives - -tcMatchesCase ctxt matches (Check expr_ty) - = newTyVarTy openTypeKind `thenM` \ scrut_ty -> - -- openTypeKind because the scrutinee can be an unboxed type - tcMatches ctxt matches (Check (mkFunTy scrut_ty expr_ty)) `thenM` \ matches' -> - returnM (scrut_ty, matches') - -tcMatchesCase ctxt matches (Infer hole) - = newHole `thenM` \ fun_hole -> - tcMatches ctxt matches (Infer fun_hole) `thenM` \ matches' -> - readMutVar fun_hole `thenM` \ fun_ty -> - -- The result of tcMatches is bound to be a function type - unifyFunTy fun_ty `thenM` \ (scrut_ty, res_ty) -> - writeMutVar hole res_ty `thenM_` - returnM (scrut_ty, matches') - - -tcMatchLambda :: LMatch Name -> Expected TcRhoType -> TcM (LMatch TcId) -tcMatchLambda match res_ty = tcMatch match_ctxt res_ty match + -> TcM (MatchGroup TcId) -- Translated alternatives + +tcMatchesCase ctxt scrut_ty matches exp_ty + = do { exp_ty' <- zapExpectedBranches matches exp_ty + ; tcMatches ctxt [Check scrut_ty] exp_ty' matches } + +tcMatchLambda :: MatchGroup Name -> Expected TcRhoType -> TcM (MatchGroup TcId) +tcMatchLambda match exp_ty -- One branch so no unifyBranches needed + = subFunTys match exp_ty $ \ pat_tys rhs_ty -> + tcMatches match_ctxt pat_tys rhs_ty match where match_ctxt = MC { mc_what = LambdaExpr, mc_body = tcMonoExpr } @@ -137,26 +129,6 @@ tcGRHSsPat grhss exp_ty = tcGRHSs match_ctxt grhss exp_ty mc_body = tcMonoExpr } \end{code} -\begin{code} -data TcMatchCtxt -- c.f. TcStmtCtxt, also in this module - = MC { mc_what :: HsMatchContext Name, -- What kind of thing this is - mc_body :: LHsExpr Name -- Type checker for a body of an alternative - -> Expected TcRhoType - -> TcM (LHsExpr TcId) } - -tcMatches :: TcMatchCtxt - -> [LMatch Name] - -> Expected TcRhoType - -> TcM [LMatch TcId] - -tcMatches ctxt matches exp_ty - = -- If there is more than one branch, and exp_ty is a 'hole', - -- all branches must be types, not type schemes, otherwise the - -- order in which we check them would affect the result. - zapExpectedBranches matches exp_ty `thenM` \ exp_ty' -> - mappM (tcMatch ctxt exp_ty') matches -\end{code} - %************************************************************************ %* * @@ -165,52 +137,68 @@ tcMatches ctxt matches exp_ty %************************************************************************ \begin{code} +tcMatches :: TcMatchCtxt + -> [Expected TcRhoType] -- Expected pattern types + -> Expected TcRhoType -- Expected result-type of the Match. + -> MatchGroup Name + -> TcM (MatchGroup TcId) + +data TcMatchCtxt -- c.f. TcStmtCtxt, also in this module + = MC { mc_what :: HsMatchContext Name, -- What kind of thing this is + mc_body :: LHsExpr Name -- Type checker for a body of an alternative + -> Expected TcRhoType + -> TcM (LHsExpr TcId) } + +tcMatches ctxt pat_tys rhs_ty (MatchGroup matches _) + = do { matches' <- mapM (tcMatch ctxt pat_tys rhs_ty) matches + ; pat_tys' <- mapM readExpectedType pat_tys + ; rhs_ty' <- readExpectedType rhs_ty + ; return (MatchGroup matches' (mkFunTys pat_tys' rhs_ty')) } + +------------- tcMatch :: TcMatchCtxt - -> Expected TcRhoType -- Expected result-type of the Match. - -- Early unification with this guy gives better error messages - -- We regard the Match as having type - -- (ty1 -> ... -> tyn -> result_ty) - -- where there are n patterns. + -> [Expected TcRhoType] -- Expected pattern types + -> Expected TcRhoType -- Expected result-type of the Match. -> LMatch Name -> TcM (LMatch TcId) -tcMatch ctxt exp_ty match = wrapLocM (tc_match ctxt exp_ty) match +tcMatch ctxt pat_tys rhs_ty match + = wrapLocM (tc_match ctxt pat_tys rhs_ty) match -tc_match ctxt expected_ty match@(Match pats maybe_rhs_sig grhss) - = addErrCtxt (matchCtxt (mc_what ctxt) match) $ -- I'm not sure why, so I put it back - subFunTys pats expected_ty $ \ pats_w_tys rhs_ty -> - -- This is the unique place we call subFunTys - -- The point is that if expected_y is a "hole", we want - -- to make arg_ty and rest_ty as "holes" too. - tcMatchPats pats_w_tys rhs_ty (tc_grhss rhs_ty) `thenM` \ (pats', grhss', ex_binds) -> - returnM (Match pats' Nothing (glueBindsOnGRHSs ex_binds grhss')) +tc_match ctxt pat_tys rhs_ty match@(Match pats maybe_rhs_sig grhss) + = addErrCtxt (matchCtxt (mc_what ctxt) match) $ + do { (pats', grhss') <- tcMatchPats pats pat_tys rhs_ty $ + tc_grhss ctxt maybe_rhs_sig grhss rhs_ty + ; returnM (Match pats' Nothing grhss') } - where - tc_grhss rhs_ty - = case maybe_rhs_sig of -- Deal with the result signature - Nothing -> tcGRHSs ctxt grhss rhs_ty - - Just sig -> tcAddScopedTyVars [sig] $ - -- Bring into scope the type variables in the signature - tcHsSigType ResSigCtxt sig `thenM` \ sig_ty -> - tcThingWithSig sig_ty (tcGRHSs ctxt grhss . Check) rhs_ty `thenM` \ (co_fn, grhss') -> - - -- Pushes the coercion down to the right hand sides, - -- because there is no convenient place to hang it otherwise. - if isIdCoercion co_fn then - returnM grhss' - else - readExpectedType rhs_ty `thenM` \ rhs_ty' -> - returnM (lift_grhss co_fn rhs_ty' grhss') - -lift_grhss co_fn rhs_ty (GRHSs grhss binds ty) - = GRHSs (map (fmap lift_grhs) grhss) binds rhs_ty -- Change the type, since the coercion does + +------------- +tc_grhss ctxt Nothing grhss rhs_ty + = tcGRHSs ctxt grhss rhs_ty -- No result signature + +tc_grhss ctxt (Just res_sig) grhss rhs_ty + = do { (sig_tvs, sig_ty) <- tcHsPatSigType ResSigCtxt res_sig + ; traceTc (text "tc_grhss" <+> ppr sig_tvs) + ; (co_fn, grhss') <- tcExtendTyVarEnv sig_tvs $ + tcThingWithSig sig_ty (tcGRHSs ctxt grhss . Check) rhs_ty + + -- Push the coercion down to the right hand sides, + -- because there is no convenient place to hang it otherwise. + ; if isIdCoercion co_fn then + return grhss' + else + return (lift_grhss co_fn grhss') } + +------------- +lift_grhss co_fn (GRHSs grhss binds) + = GRHSs (map (fmap lift_grhs) grhss) binds where lift_grhs (GRHS stmts) = GRHS (map lift_stmt stmts) lift_stmt (L loc (ResultStmt e)) = L loc (ResultStmt (fmap (co_fn <$>) e)) lift_stmt stmt = stmt +------------- tcGRHSs :: TcMatchCtxt -> GRHSs Name -> Expected TcRhoType -> TcM (GRHSs TcId) @@ -221,13 +209,12 @@ tcGRHSs :: TcMatchCtxt -> GRHSs Name -- f = \(x::forall a.a->a) -> <stuff> -- This is a consequence of the fact that tcStmts takes a TcType, -- not a Expected TcType, a decision we could revisit if necessary -tcGRHSs ctxt (GRHSs [L loc1 (GRHS [L loc2 (ResultStmt rhs)])] binds _) exp_ty +tcGRHSs ctxt (GRHSs [L loc1 (GRHS [L loc2 (ResultStmt rhs)])] binds) exp_ty = tcBindsAndThen glueBindsOnGRHSs binds $ mc_body ctxt rhs exp_ty `thenM` \ rhs' -> - readExpectedType exp_ty `thenM` \ exp_ty' -> - returnM (GRHSs [L loc1 (GRHS [L loc2 (ResultStmt rhs')])] [] exp_ty') + returnM (GRHSs [L loc1 (GRHS [L loc2 (ResultStmt rhs')])] []) -tcGRHSs ctxt (GRHSs grhss binds _) exp_ty +tcGRHSs ctxt (GRHSs grhss binds) exp_ty = tcBindsAndThen glueBindsOnGRHSs binds $ zapExpectedType exp_ty openTypeKind `thenM` \ exp_ty' -> -- Even if there is only one guard, we zap the RHS type to @@ -235,7 +222,7 @@ tcGRHSs ctxt (GRHSs grhss binds _) exp_ty -- and even a one-armed guard has a notional second arm let stmt_ctxt = SC { sc_what = PatGuard (mc_what ctxt), - sc_rhs = tcCheckRho, + sc_rhs = tcInferRho, sc_body = sc_body, sc_ty = exp_ty' } sc_body body = mc_body ctxt body (Check exp_ty') @@ -245,7 +232,7 @@ tcGRHSs ctxt (GRHSs grhss binds _) exp_ty returnM (GRHS guarded') in mappM (wrapLocM tc_grhs) grhss `thenM` \ grhss' -> - returnM (GRHSs grhss' [] exp_ty') + returnM (GRHSs grhss' []) \end{code} @@ -267,7 +254,7 @@ tcThingWithSig sig_ty thing_inside res_ty -- else we risk instantiating a ? res_ty to a forall-type -- which breaks the invariant that tcMonoExpr only returns phi-types tcGen sig_ty emptyVarSet thing_inside `thenM` \ (gen_fn, result) -> - tcInstCall SignatureOrigin sig_ty `thenM` \ (inst_fn, inst_sig_ty) -> + tcInstCall InstSigOrigin sig_ty `thenM` \ (inst_fn, _, inst_sig_ty) -> tcSubExp res_ty inst_sig_ty `thenM` \ co_fn -> returnM (co_fn <.> inst_fn <.> gen_fn, result) -- Note that we generalise, then instantiate. Ah well. @@ -281,109 +268,48 @@ tcThingWithSig sig_ty thing_inside res_ty %************************************************************************ \begin{code} -tcMatchPats - :: [(LPat Name, Expected TcRhoType)] - -> Expected TcRhoType - -> TcM a - -> TcM ([LPat TcId], a, HsBindGroup TcId) +tcMatchPats :: [LPat Name] + -> [Expected TcSigmaType] -- Pattern types + -> Expected TcRhoType -- Result type; + -- used only to check existential escape + -> TcM a + -> TcM ([LPat TcId], a) -- Typecheck the patterns, extend the environment to bind the variables, -- do the thing inside, use any existentially-bound dictionaries to -- discharge parts of the returning LIE, and deal with pattern type -- signatures -tcMatchPats pats_w_tys body_ty thing_inside - = -- STEP 1: Bring pattern-signature type variables into scope - tcAddScopedTyVars (collectSigTysFromPats (map fst pats_w_tys)) ( - - -- STEP 2: Typecheck the patterns themselves, gathering all the stuff - -- then do the thing inside - getLIE (tc_match_pats pats_w_tys thing_inside) - - ) `thenM` \ ((pats', ex_tvs, ex_ids, ex_lie, result), lie_req) -> - - -- STEP 4: Check for existentially bound type variables - -- Do this *outside* the scope of the tcAddScopedTyVars, else checkSigTyVars - -- complains that 'a' is captured by the inscope 'a'! (Test (d) in checkSigTyVars.) - -- - -- I'm a bit concerned that lie_req1 from an 'inner' pattern in the list - -- might need (via lie_req2) something made available from an 'outer' - -- pattern. But it's inconvenient to deal with, and I can't find an example - tcCheckExistentialPat ex_tvs ex_ids ex_lie lie_req - pats_w_tys body_ty `thenM` \ ex_binds -> - -- NB: we *must* pass "pats_w_tys" not just "body_ty" to tcCheckExistentialPat +tcMatchPats pats tys body_ty thing_inside + = do { do_refinement <- can_refine body_ty + ; (pats', ex_tvs, res) <- tcPats (LamPat do_refinement) pats tys thing_inside + ; tcCheckExistentialPat pats' ex_tvs tys body_ty + ; returnM (pats', res) } + where + -- Do GADT refinement if we are doing checking (not inference) + -- and the body_ty is completely rigid + -- ToDo: explain why + can_refine (Infer _) = return False + can_refine (Check ty) = isRigidType ty + +tcCheckExistentialPat :: [LPat TcId] -- Patterns (just for error message) + -> [TcTyVar] -- Existentially quantified tyvars bound by pattern + -> [Expected TcSigmaType] -- Types of the patterns + -> Expected TcRhoType -- Type of the body of the match + -- Tyvars in either of these must not escape + -> TcM () + -- NB: we *must* pass "pats_tys" not just "body_ty" to tcCheckExistentialPat -- For example, we must reject this program: -- data C = forall a. C (a -> Int) -- f (C g) x = g x -- Here, result_ty will be simply Int, but expected_ty is (C -> a -> Int). - returnM (pats', result, HsBindGroup ex_binds [] Recursive) - -tc_match_pats [] thing_inside - = thing_inside `thenM` \ answer -> - returnM ([], emptyBag, [], [], answer) +tcCheckExistentialPat pats [] pat_tys body_ty + = return () -- Short cut for case when there are no existentials -tc_match_pats ((pat,pat_ty):pats) thing_inside - = tcPat tcMonoPatBndr pat pat_ty `thenM` \ (pat', ex_tvs, pat_bndrs, ex_lie) -> - let - xve = bagToList pat_bndrs - ex_ids = [id | (_, id) <- xve] - -- ex_ids is all the pattern-bound Ids, a superset - -- of the existential Ids used in checkExistentialPat - in - tcExtendLocalValEnv2 xve $ - traceTc (text "tc_match_pats" <+> (ppr xve $$ ppr (map (idType . snd) xve) $$ - ppr (map (typeKind . idType . snd) xve))) `thenM_` - tc_match_pats pats thing_inside `thenM` \ (pats', exs_tvs, exs_ids, exs_lie, answer) -> - returnM ( pat':pats', - ex_tvs `unionBags` exs_tvs, - ex_ids ++ exs_ids, - ex_lie ++ exs_lie, - answer - ) - - -tcCheckExistentialPat :: Bag TcTyVar -- Existentially quantified tyvars bound by pattern - -> [TcId] -- Ids bound by this pattern; used - -- (a) by bindsInstsOfLocalFuns - -- (b) to generate helpful error messages - -> [Inst] -- and context - -> [Inst] -- Required context - -> [(pat,Expected TcRhoType)] -- Types of the patterns - -> Expected TcRhoType -- Type of the body of the match - -- Tyvars in either of these must not escape - -> TcM TcDictBinds -- LIE to float out and dict bindings -tcCheckExistentialPat ex_tvs ex_ids ex_lie lie_req pats_w_tys body_ty - | isEmptyBag ex_tvs && all not_overloaded ex_ids - -- Short cut for case when there are no existentials - -- and no polymorphic overloaded variables - -- e.g. f :: (forall a. Ord a => a -> a) -> Int -> Int - -- f op x = .... - -- Here we must discharge op Methods - = ASSERT( null ex_lie ) - extendLIEs lie_req `thenM_` - returnM emptyBag - - | otherwise - = -- Read the by-now-filled-in expected types - mapM readExpectedType (body_ty : map snd pats_w_tys) `thenM` \ tys -> - addErrCtxtM (sigPatCtxt tv_list ex_ids tys) $ - - -- In case there are any polymorpic, overloaded binders in the pattern - -- (which can happen in the case of rank-2 type signatures, or data constructors - -- with polymorphic arguments), we must do a bindInstsOfLocalFns here - getLIE (bindInstsOfLocalFuns lie_req ex_ids) `thenM` \ (inst_binds, lie) -> - - -- Deal with overloaded functions bound by the pattern - tcSimplifyCheck doc tv_list ex_lie lie `thenM` \ dict_binds -> - - -- Check for type variable escape - checkSigTyVarsWrt (tyVarsOfTypes tys) tv_list `thenM_` - - returnM (dict_binds `unionBags` inst_binds) - where - doc = text ("existential context of a data constructor") - tv_list = bagToList ex_tvs - not_overloaded id = not (isOverloadedTy (idType id)) +tcCheckExistentialPat pats ex_tvs pat_tys body_ty + = do { tys <- mapM readExpectedType (body_ty : pat_tys) + ; addErrCtxtM (sigPatCtxt (collectPatsBinders pats) ex_tvs tys) $ + checkSigTyVarsWrt (tyVarsOfTypes tys) ex_tvs } \end{code} @@ -399,22 +325,24 @@ tcDoStmts :: HsStmtContext Name -> TcRhoType -- To keep it simple, we don't have an "expected" type here -> TcM ([LStmt TcId], ReboundNames TcId) tcDoStmts PArrComp stmts method_names res_ty - = unifyPArrTy res_ty `thenM` \elt_ty -> - tcComprehension PArrComp mkPArrTy elt_ty stmts `thenM` \ stmts' -> - returnM (stmts', [{- unused -}]) + = do { [elt_ty] <- unifyTyConApp parrTyCon res_ty + ; stmts' <- tcComprehension PArrComp parrTyCon elt_ty stmts + ; return (stmts', [{- unused -}]) } tcDoStmts ListComp stmts method_names res_ty = unifyListTy res_ty ` thenM` \ elt_ty -> - tcComprehension ListComp mkListTy elt_ty stmts `thenM` \ stmts' -> + tcComprehension ListComp listTyCon elt_ty stmts `thenM` \ stmts' -> returnM (stmts', [{- unused -}]) tcDoStmts do_or_mdo stmts method_names res_ty - = newTyVarTy (mkArrowKind liftedTypeKind liftedTypeKind) `thenM` \ m_ty -> - newTyVarTy liftedTypeKind `thenM` \ elt_ty -> + = newTyFlexiVarTy (mkArrowKind liftedTypeKind liftedTypeKind) `thenM` \ m_ty -> + newTyFlexiVarTy liftedTypeKind `thenM` \ elt_ty -> unifyTauTy res_ty (mkAppTy m_ty elt_ty) `thenM_` let ctxt = SC { sc_what = do_or_mdo, - sc_rhs = \ rhs rhs_elt_ty -> tcCheckRho rhs (mkAppTy m_ty rhs_elt_ty), + sc_rhs = \ rhs -> do { (rhs', rhs_ty) <- tcInferRho rhs + ; rhs_elt_ty <- unifyAppTy m_ty rhs_ty + ; return (rhs', rhs_elt_ty) }, sc_body = \ body -> tcCheckRho body res_ty, sc_ty = res_ty } in @@ -431,13 +359,15 @@ tcDoStmts do_or_mdo stmts method_names res_ty returnM (stmts', methods) -tcComprehension do_or_lc mk_mty elt_ty stmts +tcComprehension do_or_lc m_tycon elt_ty stmts = tcStmts ctxt stmts where ctxt = SC { sc_what = do_or_lc, - sc_rhs = \ rhs rhs_elt_ty -> tcCheckRho rhs (mk_mty rhs_elt_ty), - sc_body = \ body -> tcCheckRho body elt_ty, -- Note: no mk_mty! - sc_ty = mk_mty elt_ty } + sc_rhs = \ rhs -> do { (rhs', rhs_ty) <- tcInferRho rhs + ; [rhs_elt_ty] <- unifyTyConApp m_tycon rhs_ty + ; return (rhs', rhs_elt_ty) }, + sc_body = \ body -> tcCheckRho body elt_ty, -- Note: no m_tycon here! + sc_ty = mkTyConApp m_tycon [elt_ty] } \end{code} @@ -476,10 +406,17 @@ tcStmts ctxt stmts data TcStmtCtxt = SC { sc_what :: HsStmtContext Name, -- What kind of thing this is - sc_rhs :: LHsExpr Name -> TcType -> TcM (LHsExpr TcId), -- Type checker for RHS computations + sc_rhs :: LHsExpr Name -> TcM (LHsExpr TcId, TcType), -- Type inference for RHS computations sc_body :: LHsExpr Name -> TcM (LHsExpr TcId), -- Type checker for return computation sc_ty :: TcType } -- Return type; used *only* to check -- for escape in existential patterns + -- We use type *inference* for the RHS computations, becuase of GADTs. + -- do { pat <- rhs; <rest> } + -- is rather like + -- case rhs of { pat -> <rest> } + -- We do inference on rhs, so that information about its type can be refined + -- when type-checking the pattern. + tcStmtsAndThen :: (LStmt TcId -> thing -> thing) -- Combiner -> TcStmtCtxt @@ -505,25 +442,21 @@ tcStmtAndThen combine ctxt (L _ (LetStmt binds)) thing_inside -- BindStmt tcStmtAndThen combine ctxt (L src_loc stmt@(BindStmt pat exp)) thing_inside - = addSrcSpan src_loc $ + = setSrcSpan src_loc $ addErrCtxt (stmtCtxt ctxt stmt) $ - newTyVarTy liftedTypeKind `thenM` \ pat_ty -> - sc_rhs ctxt exp pat_ty `thenM` \ exp' -> - tcMatchPats [(pat, Check pat_ty)] (Check (sc_ty ctxt)) ( - popErrCtxt thing_inside - ) `thenM` \ ([pat'], thing, dict_binds) -> - returnM (combine (L src_loc (BindStmt pat' exp')) - (glue_binds combine dict_binds thing)) + do { (exp', pat_ty) <- sc_rhs ctxt exp + ; ([pat'], thing) <- tcMatchPats [pat] [Check pat_ty] (Check (sc_ty ctxt)) $ + popErrCtxt thing_inside + ; return (combine (L src_loc (BindStmt pat' exp')) thing) } -- ExprStmt tcStmtAndThen combine ctxt (L src_loc stmt@(ExprStmt exp _)) thing_inside - = addSrcSpan src_loc ( + = setSrcSpan src_loc ( addErrCtxt (stmtCtxt ctxt stmt) $ if isDoExpr (sc_what ctxt) then -- do or mdo; the expression is a computation - newTyVarTy liftedTypeKind `thenM` \ any_ty -> - sc_rhs ctxt exp any_ty `thenM` \ exp' -> - returnM (L src_loc (ExprStmt exp' any_ty)) + sc_rhs ctxt exp `thenM` \ (exp', exp_ty) -> + returnM (L src_loc (ExprStmt exp' exp_ty)) else -- List comprehensions, pattern guards; expression is a boolean tcCheckRho exp boolTy `thenM` \ exp' -> returnM (L src_loc (ExprStmt exp' boolTy)) @@ -553,18 +486,19 @@ tcStmtAndThen combine ctxt (L src_loc (ParStmt bndr_stmts_s)) thing_inside -- RecStmt tcStmtAndThen combine ctxt (L src_loc (RecStmt stmts laterNames recNames _)) thing_inside - = newTyVarTys (length recNames) liftedTypeKind `thenM` \ recTys -> +-- gaw 2004 + = newTyFlexiVarTys (length recNames) liftedTypeKind `thenM` \ recTys -> let rec_ids = zipWith mkLocalId recNames recTys in - tcExtendLocalValEnv rec_ids $ + tcExtendIdEnv rec_ids $ tcStmtsAndThen combine_rec ctxt stmts ( zipWithM tc_ret recNames recTys `thenM` \ rec_rets -> tcLookupLocalIds laterNames `thenM` \ later_ids -> returnM ([], (later_ids, rec_rets)) ) `thenM` \ (stmts', (later_ids, rec_rets)) -> - tcExtendLocalValEnv later_ids $ + tcExtendIdEnv later_ids $ -- NB: The rec_ids for the recursive things -- already scope over this part thing_inside `thenM` \ thing -> @@ -604,8 +538,9 @@ glue_binds combine binds thing = combine (noLoc (LetStmt [binds])) thing number of args are used in each equation. \begin{code} -sameNoOfArgs :: [LMatch Name] -> Bool -sameNoOfArgs matches = isSingleton (nub (map args_in_match matches)) +sameNoOfArgs :: MatchGroup Name -> Bool +sameNoOfArgs (MatchGroup matches _) + = isSingleton (nub (map args_in_match matches)) where args_in_match :: LMatch Name -> Int args_in_match (L _ (Match pats _ _)) = length pats @@ -624,7 +559,7 @@ stmtCtxt ctxt stmt = hang (ptext SLIT("In") <+> pp_ctxt (sc_what ctxt) <> colon) ResultStmt _ -> pprStmtResultContext other -> pprStmtContext -sigPatCtxt bound_tvs bound_ids tys tidy_env +sigPatCtxt bound_ids bound_tvs tys tidy_env = -- tys is (body_ty : pat_tys) mapM zonkTcType tys `thenM` \ tys' -> let diff --git a/ghc/compiler/typecheck/TcPat.lhs b/ghc/compiler/typecheck/TcPat.lhs index e778e72161..c038f7e5f4 100644 --- a/ghc/compiler/typecheck/TcPat.lhs +++ b/ghc/compiler/typecheck/TcPat.lhs @@ -4,42 +4,44 @@ \section[TcPat]{Typechecking patterns} \begin{code} -module TcPat ( tcPat, tcMonoPatBndr, tcSubPat, - badFieldCon, polyPatSig - ) where +module TcPat ( tcPat, tcPats, PatCtxt(..), badFieldCon, polyPatSig ) where #include "HsVersions.h" -import HsSyn ( Pat(..), LPat, HsConDetails(..), HsLit(..), HsOverLit(..), HsExpr(..) ) +import HsSyn ( Pat(..), LPat, HsConDetails(..), HsLit(..), HsOverLit(..), + HsExpr(..), LHsBinds, emptyLHsBinds, isEmptyLHsBinds ) import HsUtils -import TcHsSyn ( TcId, hsLitType, - mkCoercion, idCoercion, isIdCoercion, - (<$>), PatCoFn ) - +import TcHsSyn ( TcId, hsLitType ) import TcRnMonad import Inst ( InstOrigin(..), newMethodFromName, newOverloadedLit, newDicts, - instToId, tcInstDataCon, tcSyntaxName + instToId, tcInstStupidTheta, tcSyntaxName ) -import Id ( idType, mkLocalId, mkSysLocal ) +import Id ( Id, idType, mkLocalId ) import Name ( Name ) -import FieldLabel ( fieldLabelName ) -import TcEnv ( tcLookupClass, tcLookupLocatedDataCon, tcLookupId ) -import TcMType ( newTyVarTy, arityErr ) -import TcType ( TcType, TcTyVar, TcSigmaType, TyVarDetails(..), mkClassPred ) +import TcSimplify ( tcSimplifyCheck, bindInstsOfLocalFuns ) +import TcEnv ( newLocalName, tcExtendIdEnv1, tcExtendTyVarEnv, + tcLookupClass, tcLookupDataCon, tcLookupId ) +import TcMType ( newTyFlexiVarTy, arityErr, tcSkolTyVars, isRigidType ) +import TcType ( TcType, TcTyVar, TcSigmaType, TcTauType, zipTopTvSubst, + SkolemInfo(PatSkol), isSkolemTyVar, pprSkolemTyVar, + mkTyVarTys, mkClassPred, mkTyConApp, isOverloadedTy ) import Kind ( argTypeKind, liftedTypeKind ) -import TcUnify ( tcSubOff, Expected(..), readExpectedType, zapExpectedType, - unifyTauTy, zapToListTy, zapToPArrTy, zapToTupleTy ) -import TcHsType ( tcHsSigType, UserTypeCtxt(..) ) - -import TysWiredIn ( stringTy ) +import TcUnify ( tcSubPat, Expected(..), zapExpectedType, + zapExpectedTo, zapToListTy, zapToTyConApp ) +import TcHsType ( UserTypeCtxt(..), TcSigInfo( sig_tau ), TcSigFun, tcHsPatSigType ) +import TysWiredIn ( stringTy, parrTyCon, tupleTyCon ) +import Unify ( MaybeErr(..), tcRefineTys, tcMatchTys ) +import Type ( substTys, substTheta ) import CmdLineOpts ( opt_IrrefutableTuples ) -import DataCon ( DataCon, dataConFieldLabels, dataConSourceArity ) +import TyCon ( TyCon ) +import DataCon ( DataCon, dataConTyCon, isVanillaDataCon, dataConInstOrigArgTys, + dataConFieldLabels, dataConSourceArity, dataConSig ) import PrelNames ( eqStringName, eqName, geName, negateName, minusName, integralClassName ) import BasicTypes ( isBoxed ) -import SrcLoc ( Located(..), noLoc, unLoc, noLoc ) -import Bag +import SrcLoc ( Located(..), noLoc, unLoc ) +import ErrUtils ( Message ) import Outputable import FastString \end{code} @@ -47,108 +49,170 @@ import FastString %************************************************************************ %* * -\subsection{Variable patterns} + External interface %* * %************************************************************************ +Note [Nesting] + +tcPat takes a "thing inside" over which the patter scopes. This is partly +so that tcPat can extend the environment for the thing_inside, but also +so that constraints arising in the thing_inside can be discharged by the +pattern. + +This does not work so well for the ErrCtxt carried by the monad: we don't +want the error-context for the pattern to scope over the RHS. +Hence the getErrCtxt/setErrCtxt stuff in tcPat. + \begin{code} -type BinderChecker = Name -> Expected TcSigmaType -> TcM (PatCoFn, TcId) - -- How to construct a suitable (monomorphic) - -- Id for variables found in the pattern - -- The TcSigmaType is the expected type - -- from the pattern context - --- The Id may have a sigma type (e.g. f (x::forall a. a->a)) --- so we want to *create* it during pattern type checking. --- We don't want to make Ids first with a type-variable type --- and then unify... becuase we can't unify a sigma type with a type variable. - -tcMonoPatBndr :: BinderChecker - -- This is the right function to pass to tcPat when - -- we're looking at a lambda-bound pattern, - -- so there's no polymorphic guy to worry about - -tcMonoPatBndr binder_name pat_ty - = zapExpectedType pat_ty argTypeKind `thenM` \ pat_ty' -> - -- If there are *no constraints* on the pattern type, we - -- revert to good old H-M typechecking, making - -- the type of the binder into an *ordinary* - -- type variable. We find out if there are no constraints - -- by seeing if we are given an "open hole" as our info. - -- What we are trying to avoid here is giving a binder - -- a type that is a 'hole'. The only place holes should - -- appear is as an argument to tcPat and tcExpr/tcMonoExpr. - - returnM (idCoercion, mkLocalId binder_name pat_ty') +tcPat :: PatCtxt + -> LPat Name -> Expected TcSigmaType + -> TcM a -- Thing inside + -> TcM (LPat TcId, -- Translated pattern + [TcTyVar], -- Existential binders + a) -- Result of thing inside + +tcPat ctxt pat exp_ty thing_inside + = do { err_ctxt <- getErrCtxt + ; maybeAddErrCtxt (patCtxt (unLoc pat)) $ + tc_lpat ctxt pat exp_ty $ + setErrCtxt err_ctxt thing_inside } + -- Restore error context before doing thing_inside + -- See note [Nesting] above + +-------------------- +tcPats :: PatCtxt + -> [LPat Name] + -> [Expected TcSigmaType] -- Excess types discarded + -> TcM a + -> TcM ([LPat TcId], [TcTyVar], a) + +tcPats ctxt [] _ thing_inside + = do { res <- thing_inside + ; return ([], [], res) } + +tcPats ctxt (p:ps) (ty:tys) thing_inside + = do { (p', p_tvs, (ps', ps_tvs, res)) + <- tcPat ctxt p ty $ + tcPats ctxt ps tys thing_inside + ; return (p':ps', p_tvs ++ ps_tvs, res) } + +-------------------- +tcCheckPats :: PatCtxt + -> [LPat Name] -> [TcSigmaType] + -> TcM a + -> TcM ([LPat TcId], [TcTyVar], a) +tcCheckPats ctxt pats tys thing_inside -- A trivial wrapper + = tcPats ctxt pats (map Check tys) thing_inside \end{code} %************************************************************************ %* * -\subsection{Typechecking patterns} + Binders %* * %************************************************************************ \begin{code} -tcPat :: BinderChecker - -> LPat Name - - -> Expected TcSigmaType -- Expected type derived from the context - -- In the case of a function with a rank-2 signature, - -- this type might be a forall type. - - -> TcM (LPat TcId, - Bag TcTyVar, -- TyVars bound by the pattern - -- These are just the existentially-bound ones. - -- Any tyvars bound by *type signatures* in the - -- patterns are brought into scope before we begin. - Bag (Name, TcId), -- Ids bound by the pattern, along with the Name under - -- which it occurs in the pattern - -- The two aren't the same because we conjure up a new - -- local name for each variable. - [Inst]) -- Dicts or methods [see below] bound by the pattern - -- from existential constructor patterns -tcPat tc_bndr (L span pat) exp_ty - = addSrcSpan span $ - do { (pat', tvs, ids, lie) <- tc_pat tc_bndr pat exp_ty - ; return (L span pat', tvs, ids, lie) } +data PatCtxt = LamPat Bool | LetPat TcSigFun + -- True <=> we are checking the case expression, + -- so can do full-blown refinement + -- False <=> inferring, do no refinement + +------------------- +tcPatBndr :: PatCtxt -> Name -> Expected TcSigmaType -> TcM TcId +tcPatBndr (LamPat _) bndr_name pat_ty + = do { pat_ty' <- zapExpectedType pat_ty argTypeKind + -- If pat_ty is Expected, this returns the appropriate + -- SigmaType. In Infer mode, we create a fresh type variable. + -- Note the SigmaType: we can get + -- data T = MkT (forall a. a->a) + -- f t = case t of { MkT g -> ... } + -- Here, the 'g' must get type (forall a. a->a) from the + -- MkT context + ; return (mkLocalId bndr_name pat_ty') } + +tcPatBndr (LetPat lookup_sig) bndr_name pat_ty + | Just sig <- lookup_sig bndr_name + = do { let mono_ty = sig_tau sig + ; mono_name <- newLocalName bndr_name + ; tcSubPat mono_ty pat_ty + ; return (mkLocalId mono_name mono_ty) } + + | otherwise + = do { mono_name <- newLocalName bndr_name + ; pat_ty' <- zapExpectedType pat_ty argTypeKind + ; return (mkLocalId mono_name pat_ty') } + + +------------------- +bindInstsOfPatId :: TcId -> TcM a -> TcM (a, LHsBinds TcId) +bindInstsOfPatId id thing_inside + | not (isOverloadedTy (idType id)) + = do { res <- thing_inside; return (res, emptyLHsBinds) } + | otherwise + = do { (res, lie) <- getLIE thing_inside + ; binds <- bindInstsOfLocalFuns lie [id] + ; return (res, binds) } \end{code} %************************************************************************ %* * -\subsection{Variables, wildcards, lazy pats, as-pats} + tc_pat: the main worker function %* * %************************************************************************ \begin{code} -tc_pat tc_bndr pat@(TypePat ty) pat_ty - = failWithTc (badTypePat pat) - -tc_pat tc_bndr (VarPat name) pat_ty - = tc_bndr name pat_ty `thenM` \ (co_fn, bndr_id) -> - returnM (co_fn <$> VarPat bndr_id, - emptyBag, unitBag (name, bndr_id), []) - -tc_pat tc_bndr (LazyPat pat) pat_ty - = tcPat tc_bndr pat pat_ty `thenM` \ (pat', tvs, ids, lie_avail) -> - returnM (LazyPat pat', tvs, ids, lie_avail) - -tc_pat tc_bndr pat_in@(AsPat (L nm_loc name) pat) pat_ty - = addSrcSpan nm_loc (tc_bndr name pat_ty) `thenM` \ (co_fn, bndr_id) -> - tcPat tc_bndr pat (Check (idType bndr_id)) `thenM` \ (pat', tvs, ids, lie_avail) -> - -- NB: if we have: - -- \ (y@(x::forall a. a->a)) = e - -- we'll fail. The as-pattern infers a monotype for 'y', which then - -- fails to unify with the polymorphic type for 'x'. This could be - -- fixed, but only with a bit more work. - returnM (co_fn <$> (AsPat (L nm_loc bndr_id) pat'), - tvs, (name, bndr_id) `consBag` ids, lie_avail) - -tc_pat tc_bndr (WildPat _) pat_ty - = zapExpectedType pat_ty argTypeKind `thenM` \ pat_ty' -> - -- We might have an incoming 'hole' type variable; no annotation - -- so zap it to a type. Rather like tcMonoPatBndr. +tc_lpat :: PatCtxt + -> LPat Name -> Expected TcSigmaType + -> TcM a -- Thing inside + -> TcM (LPat TcId, -- Translated pattern + [TcTyVar], -- Existential binders + a) -- Result of thing inside + +tc_lpat ctxt (L span pat) pat_ty thing_inside + = setSrcSpan span $ + -- It's OK to keep setting the SrcSpan; + -- it just overwrites the previous value + do { (pat', tvs, res) <- tc_pat ctxt pat pat_ty thing_inside + ; return (L span pat', tvs, res) } + +--------------------- +tc_pat ctxt (VarPat name) pat_ty thing_inside + = do { id <- tcPatBndr ctxt name pat_ty + ; (res, binds) <- bindInstsOfPatId id $ + tcExtendIdEnv1 name id $ + (traceTc (text "binding" <+> ppr name <+> ppr (idType id)) + >> thing_inside) + ; let pat' | isEmptyLHsBinds binds = VarPat id + | otherwise = VarPatOut id binds + ; return (pat', [], res) } + +tc_pat ctxt (ParPat pat) pat_ty thing_inside + = do { (pat', tvs, res) <- tc_lpat ctxt pat pat_ty thing_inside + ; return (ParPat pat', tvs, res) } + +-- There's a wrinkle with irrefuatable patterns, namely that we +-- must not propagate type refinement from them. For example +-- data T a where { T1 :: Int -> T Int; ... } +-- f :: T a -> Int -> a +-- f ~(T1 i) y = y +-- It's obviously not sound to refine a to Int in the right +-- hand side, because the arugment might not match T1 at all! +-- +-- Nor should a lazy pattern bind any existential type variables +-- because they won't be in scope when we do the desugaring +tc_pat ctxt lpat@(LazyPat pat) pat_ty thing_inside + = do { reft <- getTypeRefinement + ; (pat', pat_tvs, res) <- tc_lpat ctxt pat pat_ty $ + setTypeRefinement reft thing_inside + ; if (null pat_tvs) then return () + else lazyPatErr lpat pat_tvs + ; return (LazyPat pat', [], res) } + +tc_pat ctxt (WildPat _) pat_ty thing_inside + = do { pat_ty' <- zapExpectedType pat_ty argTypeKind -- Note argTypeKind, so that -- f _ = 3 -- is rejected when f applied to an unboxed tuple @@ -156,259 +220,234 @@ tc_pat tc_bndr (WildPat _) pat_ty -- (case g x of _ -> ...) -- is rejected g returns an unboxed tuple, which is perhpas -- annoying. I suppose we could pass the context into tc_pat... - returnM (WildPat pat_ty', emptyBag, emptyBag, []) - -tc_pat tc_bndr (ParPat parend_pat) pat_ty --- Leave the parens in, so that warnings from the --- desugarer have parens in them - = tcPat tc_bndr parend_pat pat_ty `thenM` \ (pat', tvs, ids, lie_avail) -> - returnM (ParPat pat', tvs, ids, lie_avail) - -tc_pat tc_bndr pat_in@(SigPatIn pat sig) pat_ty - = addErrCtxt (patCtxt pat_in) $ - tcHsSigType PatSigCtxt sig `thenM` \ sig_ty -> - tcSubPat sig_ty pat_ty `thenM` \ co_fn -> - tcPat tc_bndr pat (Check sig_ty) `thenM` \ (pat', tvs, ids, lie_avail) -> - returnM (co_fn <$> unLoc pat', tvs, ids, lie_avail) -\end{code} - - -%************************************************************************ -%* * -\subsection{Explicit lists, parallel arrays, and tuples} -%* * -%************************************************************************ - -\begin{code} -tc_pat tc_bndr pat_in@(ListPat pats _) pat_ty - = addErrCtxt (patCtxt pat_in) $ - zapToListTy pat_ty `thenM` \ elem_ty -> - tcPats tc_bndr pats (repeat elem_ty) `thenM` \ (pats', tvs, ids, lie_avail) -> - returnM (ListPat pats' elem_ty, tvs, ids, lie_avail) - -tc_pat tc_bndr pat_in@(PArrPat pats _) pat_ty - = addErrCtxt (patCtxt pat_in) $ - zapToPArrTy pat_ty `thenM` \ elem_ty -> - tcPats tc_bndr pats (repeat elem_ty) `thenM` \ (pats', tvs, ids, lie_avail) -> - returnM (PArrPat pats' elem_ty, tvs, ids, lie_avail) + ; res <- thing_inside + ; return (WildPat pat_ty', [], res) } + +tc_pat ctxt (AsPat (L nm_loc name) pat) pat_ty thing_inside + = do { bndr_id <- setSrcSpan nm_loc (tcPatBndr ctxt name pat_ty) + ; (pat', tvs, res) <- tcExtendIdEnv1 name bndr_id $ + tc_lpat ctxt pat (Check (idType bndr_id)) thing_inside + -- NB: if we do inference on: + -- \ (y@(x::forall a. a->a)) = e + -- we'll fail. The as-pattern infers a monotype for 'y', which then + -- fails to unify with the polymorphic type for 'x'. This could + -- perhaps be fixed, but only with a bit more work. + -- + -- If you fix it, don't forget the bindInstsOfPatIds! + ; return (AsPat (L nm_loc bndr_id) pat', tvs, res) } + +tc_pat ctxt (SigPatIn pat sig) pat_ty thing_inside + = do { -- See Note [Pattern coercions] below + (sig_tvs, sig_ty) <- tcHsPatSigType PatSigCtxt sig + ; tcSubPat sig_ty pat_ty + ; (pat', tvs, res) <- tcExtendTyVarEnv sig_tvs $ + tc_lpat ctxt pat (Check sig_ty) thing_inside + ; return (SigPatOut pat' sig_ty, tvs, res) } + +tc_pat ctxt pat@(TypePat ty) pat_ty thing_inside + = failWithTc (badTypePat pat) -tc_pat tc_bndr pat_in@(TuplePat pats boxity) pat_ty - = addErrCtxt (patCtxt pat_in) $ +------------------------ +-- Lists, tuples, arrays +tc_pat ctxt (ListPat pats _) pat_ty thing_inside + = do { elem_ty <- zapToListTy pat_ty + ; (pats', pats_tvs, res) <- tcCheckPats ctxt pats (repeat elem_ty) thing_inside + ; return (ListPat pats' elem_ty, pats_tvs, res) } - zapToTupleTy boxity arity pat_ty `thenM` \ arg_tys -> - tcPats tc_bndr pats arg_tys `thenM` \ (pats', tvs, ids, lie_avail) -> +tc_pat ctxt (PArrPat pats _) pat_ty thing_inside + = do { [elem_ty] <- zapToTyConApp parrTyCon pat_ty + ; (pats', pats_tvs, res) <- tcCheckPats ctxt pats (repeat elem_ty) thing_inside + ; return (PArrPat pats' elem_ty, pats_tvs, res) } - -- possibly do the "make all tuple-pats irrefutable" test: - let - unmangled_result = TuplePat pats' boxity +tc_pat ctxt (TuplePat pats boxity) pat_ty thing_inside + = do { let arity = length pats + tycon = tupleTyCon boxity arity + ; arg_tys <- zapToTyConApp tycon pat_ty + ; (pats', pats_tvs, res) <- tcCheckPats ctxt pats arg_tys thing_inside -- Under flag control turn a pattern (x,y,z) into ~(x,y,z) -- so that we can experiment with lazy tuple-matching. -- This is a pretty odd place to make the switch, but -- it was easy to do. - - possibly_mangled_result - | opt_IrrefutableTuples && isBoxed boxity = LazyPat (noLoc unmangled_result) - | otherwise = unmangled_result - in - returnM (possibly_mangled_result, tvs, ids, lie_avail) - where - arity = length pats -\end{code} - - -%************************************************************************ -%* * -\subsection{Other constructors} -%* * - -%************************************************************************ - -\begin{code} -tc_pat tc_bndr pat_in@(ConPatIn con_name arg_pats) pat_ty - = addErrCtxt (patCtxt pat_in) $ - - -- Check that it's a constructor, and instantiate it - tcLookupLocatedDataCon con_name `thenM` \ data_con -> - tcInstDataCon (PatOrigin pat_in) ExistTv data_con `thenM` \ (_, ex_dicts1, arg_tys, con_res_ty, ex_tvs) -> - - -- Check overall type matches. - -- The pat_ty might be a for-all type, in which - -- case we must instantiate to match - tcSubPat con_res_ty pat_ty `thenM` \ co_fn -> - - -- Check the argument patterns - tcConStuff tc_bndr data_con arg_pats arg_tys `thenM` \ (arg_pats', arg_tvs, arg_ids, ex_dicts2) -> - - returnM (co_fn <$> ConPatOut data_con arg_pats' con_res_ty ex_tvs (map instToId ex_dicts1), - listToBag ex_tvs `unionBags` arg_tvs, - arg_ids, - ex_dicts1 ++ ex_dicts2) -\end{code} - - -%************************************************************************ -%* * -\subsection{Literals} -%* * -%************************************************************************ - -\begin{code} -tc_pat tc_bndr pat@(LitPat lit@(HsString _)) pat_ty - = zapExpectedType pat_ty liftedTypeKind `thenM` \ pat_ty' -> - unifyTauTy pat_ty' stringTy `thenM_` - tcLookupId eqStringName `thenM` \ eq_id -> - returnM (NPatOut lit stringTy (nlHsVar eq_id `HsApp` nlHsLit lit), - emptyBag, emptyBag, []) - -tc_pat tc_bndr (LitPat simple_lit) pat_ty - = zapExpectedType pat_ty argTypeKind `thenM` \ pat_ty' -> - unifyTauTy pat_ty' (hsLitType simple_lit) `thenM_` - returnM (LitPat simple_lit, emptyBag, emptyBag, []) - -tc_pat tc_bndr pat@(NPatIn over_lit mb_neg) pat_ty - = zapExpectedType pat_ty liftedTypeKind `thenM` \ pat_ty' -> - newOverloadedLit origin over_lit pat_ty' `thenM` \ pos_lit_expr -> - newMethodFromName origin pat_ty' eqName `thenM` \ eq -> - (case mb_neg of - Nothing -> returnM pos_lit_expr -- Positive literal - Just neg -> -- Negative literal - -- The 'negate' is re-mappable syntax - tcSyntaxName origin pat_ty' (negateName, HsVar neg) `thenM` \ (_, neg_expr) -> - returnM (mkHsApp (noLoc neg_expr) pos_lit_expr) - ) `thenM` \ lit_expr -> - - let - -- The literal in an NPatIn is always positive... - -- But in NPat, the literal is used to find identical patterns - -- so we must negate the literal when necessary! - lit' = case (over_lit, mb_neg) of - (HsIntegral i _, Nothing) -> HsInteger i pat_ty' - (HsIntegral i _, Just _) -> HsInteger (-i) pat_ty' - (HsFractional f _, Nothing) -> HsRat f pat_ty' - (HsFractional f _, Just _) -> HsRat (-f) pat_ty' - in - returnM (NPatOut lit' pat_ty' (HsApp (nlHsVar eq) lit_expr), - emptyBag, emptyBag, []) - where - origin = PatOrigin pat -\end{code} - -%************************************************************************ -%* * -\subsection{n+k patterns} -%* * -%************************************************************************ - -\begin{code} -tc_pat tc_bndr pat@(NPlusKPatIn (L nm_loc name) lit@(HsIntegral i _) minus_name) pat_ty - = addSrcSpan nm_loc (tc_bndr name pat_ty) `thenM` \ (co_fn, bndr_id) -> - let - pat_ty' = idType bndr_id - in - newOverloadedLit origin lit pat_ty' `thenM` \ over_lit_expr -> - newMethodFromName origin pat_ty' geName `thenM` \ ge -> + ; let unmangled_result = TuplePat pats' boxity + possibly_mangled_result + | opt_IrrefutableTuples && isBoxed boxity = LazyPat (noLoc unmangled_result) + | otherwise = unmangled_result + + ; ASSERT( length arg_tys == arity ) -- Syntactically enforced + return (possibly_mangled_result, pats_tvs, res) } + +------------------------ +-- Data constructors +tc_pat ctxt pat_in@(ConPatIn (L con_span con_name) arg_pats) pat_ty thing_inside + = do { data_con <- tcLookupDataCon con_name + ; let tycon = dataConTyCon data_con + ; ty_args <- zapToTyConApp tycon pat_ty + ; (pat', tvs, res) <- tcConPat ctxt data_con tycon ty_args arg_pats thing_inside + ; return (pat', tvs, res) } + + +------------------------ +-- Literal patterns +tc_pat ctxt pat@(LitPat lit@(HsString _)) pat_ty thing_inside + = do { -- Strings are mapped to NPatOuts, which have a guard expression + zapExpectedTo pat_ty stringTy + ; eq_id <- tcLookupId eqStringName + ; res <- thing_inside + ; returnM (NPatOut lit stringTy (nlHsVar eq_id `HsApp` nlHsLit lit), [], res) } + +tc_pat ctxt (LitPat simple_lit) pat_ty thing_inside + = do { -- All other simple lits + zapExpectedTo pat_ty (hsLitType simple_lit) + ; res <- thing_inside + ; returnM (LitPat simple_lit, [], res) } + +------------------------ +-- Overloaded patterns: n, and n+k +tc_pat ctxt pat@(NPatIn over_lit mb_neg) pat_ty thing_inside + = do { pat_ty' <- zapExpectedType pat_ty liftedTypeKind + ; let origin = LiteralOrigin over_lit + ; pos_lit_expr <- newOverloadedLit origin over_lit pat_ty' + ; eq <- newMethodFromName origin pat_ty' eqName + ; lit_expr <- case mb_neg of + Nothing -> returnM pos_lit_expr -- Positive literal + Just neg -> -- Negative literal + -- The 'negate' is re-mappable syntax + do { (_, neg_expr) <- tcSyntaxName origin pat_ty' + (negateName, HsVar neg) + ; returnM (mkHsApp (noLoc neg_expr) pos_lit_expr) } + + ; let -- The literal in an NPatIn is always positive... + -- But in NPatOut, the literal is used to find identical patterns + -- so we must negate the literal when necessary! + lit' = case (over_lit, mb_neg) of + (HsIntegral i _, Nothing) -> HsInteger i pat_ty' + (HsIntegral i _, Just _) -> HsInteger (-i) pat_ty' + (HsFractional f _, Nothing) -> HsRat f pat_ty' + (HsFractional f _, Just _) -> HsRat (-f) pat_ty' + + ; res <- thing_inside + ; returnM (NPatOut lit' pat_ty' (HsApp (nlHsVar eq) lit_expr), [], res) } + +tc_pat ctxt pat@(NPlusKPatIn (L nm_loc name) lit@(HsIntegral i _) minus_name) pat_ty thing_inside + = do { bndr_id <- setSrcSpan nm_loc (tcPatBndr ctxt name pat_ty) + ; let pat_ty' = idType bndr_id + origin = LiteralOrigin lit + ; over_lit_expr <- newOverloadedLit origin lit pat_ty' + ; ge <- newMethodFromName origin pat_ty' geName -- The '-' part is re-mappable syntax - tcSyntaxName origin pat_ty' (minusName, HsVar minus_name) `thenM` \ (_, minus_expr) -> + ; (_, minus_expr) <- tcSyntaxName origin pat_ty' (minusName, HsVar minus_name) -- The Report says that n+k patterns must be in Integral -- We may not want this when using re-mappable syntax, though (ToDo?) - tcLookupClass integralClassName `thenM` \ icls -> - newDicts origin [mkClassPred icls [pat_ty']] `thenM` \ dicts -> - extendLIEs dicts `thenM_` + ; icls <- tcLookupClass integralClassName + ; dicts <- newDicts origin [mkClassPred icls [pat_ty']] + ; extendLIEs dicts - returnM (NPlusKPatOut (L nm_loc bndr_id) i - (SectionR (nlHsVar ge) over_lit_expr) - (SectionR (noLoc minus_expr) over_lit_expr), - emptyBag, unitBag (name, bndr_id), []) - where - origin = PatOrigin pat -\end{code} - - -%************************************************************************ -%* * -\subsection{Lists of patterns} -%* * -%************************************************************************ - -Helper functions - -\begin{code} -tcPats :: BinderChecker -- How to deal with variables - -> [LPat Name] -> [TcType] -- Excess 'expected types' discarded - -> TcM ([LPat TcId], - Bag TcTyVar, - Bag (Name, TcId), -- Ids bound by the pattern - [Inst]) -- Dicts bound by the pattern - -tcPats tc_bndr [] tys = returnM ([], emptyBag, emptyBag, []) - -tcPats tc_bndr (pat:pats) (ty:tys) - = tcPat tc_bndr pat (Check ty) `thenM` \ (pat', tvs1, ids1, lie_avail1) -> - tcPats tc_bndr pats tys `thenM` \ (pats', tvs2, ids2, lie_avail2) -> - - returnM (pat':pats', - tvs1 `unionBags` tvs2, ids1 `unionBags` ids2, - lie_avail1 ++ lie_avail2) + ; res <- tcExtendIdEnv1 name bndr_id thing_inside + ; returnM (NPlusKPatOut (L nm_loc bndr_id) i + (SectionR (nlHsVar ge) over_lit_expr) + (SectionR (noLoc minus_expr) over_lit_expr), + [], res) } \end{code} %************************************************************************ %* * -\subsection{Constructor arguments} + Most of the work for constructors is here + (the rest is in the ConPatIn case of tc_pat) %* * %************************************************************************ \begin{code} -tcConStuff tc_bndr data_con (PrefixCon arg_pats) arg_tys - = -- Check correct arity - checkTc (con_arity == no_of_args) - (arityErr "Constructor" data_con con_arity no_of_args) `thenM_` - - -- Check arguments - tcPats tc_bndr arg_pats arg_tys `thenM` \ (arg_pats', tvs, ids, lie_avail) -> - - returnM (PrefixCon arg_pats', tvs, ids, lie_avail) +tcConPat :: PatCtxt -> DataCon -> TyCon -> [TcTauType] + -> HsConDetails Name (LPat Name) -> TcM a + -> TcM (Pat TcId, [TcTyVar], a) +tcConPat ctxt data_con tycon ty_args arg_pats thing_inside + | isVanillaDataCon data_con + = do { let arg_tys = dataConInstOrigArgTys data_con ty_args + ; tcInstStupidTheta data_con ty_args + ; traceTc (text "tcConPat" <+> vcat [ppr data_con, ppr ty_args, ppr arg_tys]) + ; (arg_pats', tvs, res) <- tcConArgs ctxt data_con arg_pats arg_tys thing_inside + ; return (ConPatOut data_con [] [] emptyLHsBinds + arg_pats' (mkTyConApp tycon ty_args), + tvs, res) } + + | otherwise -- GADT case + = do { let (tvs, theta, arg_tys, _, res_tys) = dataConSig data_con + ; span <- getSrcSpanM + ; let rigid_info = PatSkol data_con span + ; tvs' <- tcSkolTyVars rigid_info tvs + ; let tv_tys' = mkTyVarTys tvs' + tenv = zipTopTvSubst tvs tv_tys' + theta' = substTheta tenv theta + arg_tys' = substTys tenv arg_tys + res_tys' = substTys tenv res_tys + ; dicts <- newDicts (SigOrigin rigid_info) theta' + ; tcInstStupidTheta data_con tv_tys' + + -- Do type refinement! + ; traceTc (text "tcGadtPat" <+> vcat [ppr data_con, ppr tvs', ppr arg_tys', ppr res_tys', + text "ty-args:" <+> ppr ty_args ]) + ; refineAlt ctxt data_con tvs' ty_args res_tys' $ do + + { ((arg_pats', inner_tvs, res), lie_req) + <- getLIE (tcConArgs ctxt data_con arg_pats arg_tys' thing_inside) + + ; dict_binds <- tcSimplifyCheck doc tvs' dicts lie_req + + ; return (ConPatOut data_con + tvs' (map instToId dicts) dict_binds + arg_pats' (mkTyConApp tycon ty_args), + tvs' ++ inner_tvs, res) } } + where + doc = ptext SLIT("existential context for") <+> quotes (ppr data_con) + +tcConArgs :: PatCtxt -> DataCon + -> HsConDetails Name (LPat Name) -> [TcSigmaType] + -> TcM a + -> TcM (HsConDetails TcId (LPat Id), [TcTyVar], a) + +tcConArgs ctxt data_con (PrefixCon arg_pats) arg_tys thing_inside + = do { checkTc (con_arity == no_of_args) -- Check correct arity + (arityErr "Constructor" data_con con_arity no_of_args) + ; (arg_pats', tvs, res) <- tcCheckPats ctxt arg_pats arg_tys thing_inside + ; return (PrefixCon arg_pats', tvs, res) } where con_arity = dataConSourceArity data_con no_of_args = length arg_pats -tcConStuff tc_bndr data_con (InfixCon p1 p2) arg_tys - = -- Check correct arity - checkTc (con_arity == 2) - (arityErr "Constructor" data_con con_arity 2) `thenM_` - - -- Check arguments - tcPat tc_bndr p1 (Check ty1) `thenM` \ (p1', tvs1, ids1, lie_avail1) -> - tcPat tc_bndr p2 (Check ty2) `thenM` \ (p2', tvs2, ids2, lie_avail2) -> - - returnM (InfixCon p1' p2', - tvs1 `unionBags` tvs2, ids1 `unionBags` ids2, - lie_avail1 ++ lie_avail2) +tcConArgs ctxt data_con (InfixCon p1 p2) arg_tys thing_inside + = do { checkTc (con_arity == 2) -- Check correct arity + (arityErr "Constructor" data_con con_arity 2) + ; ([p1',p2'], tvs, res) <- tcCheckPats ctxt [p1,p2] arg_tys thing_inside + ; return (InfixCon p1' p2', tvs, res) } where con_arity = dataConSourceArity data_con - [ty1, ty2] = arg_tys - -tcConStuff tc_bndr data_con (RecCon rpats) arg_tys - = -- Check the fields - tc_fields field_tys rpats `thenM` \ (rpats', tvs, ids, lie_avail) -> - returnM (RecCon rpats', tvs, ids, lie_avail) +tcConArgs ctxt data_con (RecCon rpats) arg_tys thing_inside + = do { (rpats', tvs, res) <- tc_fields rpats thing_inside + ; return (RecCon rpats', tvs, res) } where - field_tys = zip (map fieldLabelName (dataConFieldLabels data_con)) arg_tys - -- Don't use zipEqual! If the constructor isn't really a record, then - -- dataConFieldLabels will be empty (and each field in the pattern - -- will generate an error below). + tc_fields :: [(Located Name, LPat Name)] -> TcM a + -> TcM ([(Located TcId, LPat TcId)], [TcTyVar], a) + tc_fields [] thing_inside + = do { res <- thing_inside + ; return ([], [], res) } - tc_fields field_tys [] - = returnM ([], emptyBag, emptyBag, []) + tc_fields (rpat : rpats) thing_inside + = do { (rpat', tvs1, (rpats', tvs2, res)) + <- tc_field rpat (tc_fields rpats thing_inside) + ; return (rpat':rpats', tvs1 ++ tvs2, res) } - tc_fields field_tys ((L lbl_loc field_label, rhs_pat) : rpats) - = tc_fields field_tys rpats `thenM` \ (rpats', tvs1, ids1, lie_avail1) -> + tc_field (field_lbl, pat) thing_inside + = do { (sel_id, pat_ty) <- wrapLocFstM find_field_ty field_lbl + ; (pat', tvs, res) <- tcPat ctxt pat (Check pat_ty) thing_inside + ; return ((sel_id, pat'), tvs, res) } - (case [ty | (f,ty) <- field_tys, f == field_label] of + find_field_ty field_lbl + = case [ty | (f,ty) <- field_tys, f == field_lbl] of -- No matching field; chances are this field label comes from some -- other record type (or maybe none). As well as reporting an @@ -418,67 +457,110 @@ tcConStuff tc_bndr data_con (RecCon rpats) arg_tys -- f (R { foo = (a,b) }) = a+b -- If foo isn't one of R's fields, we don't want to crash when -- typechecking the "a+b". - [] -> addErrTc (badFieldCon data_con field_label) `thenM_` - newTyVarTy liftedTypeKind `thenM` \ bogus_ty -> - returnM (error "Bogus selector Id", bogus_ty) + [] -> do { addErrTc (badFieldCon data_con field_lbl) + ; bogus_ty <- newTyFlexiVarTy liftedTypeKind + ; return (error "Bogus selector Id", bogus_ty) } -- The normal case, when the field comes from the right constructor (pat_ty : extras) -> ASSERT( null extras ) - addSrcSpan lbl_loc (tcLookupId field_label) `thenM` \ sel_id -> - returnM (sel_id, pat_ty) - ) `thenM` \ (sel_id, pat_ty) -> + do { sel_id <- tcLookupId field_lbl + ; return (sel_id, pat_ty) } - tcPat tc_bndr rhs_pat (Check pat_ty) `thenM` \ (rhs_pat', tvs2, ids2, lie_avail2) -> - - returnM ((L lbl_loc sel_id, rhs_pat') : rpats', - tvs1 `unionBags` tvs2, - ids1 `unionBags` ids2, - lie_avail1 ++ lie_avail2) + field_tys = zip (dataConFieldLabels data_con) arg_tys + -- Don't use zipEqual! If the constructor isn't really a record, then + -- dataConFieldLabels will be empty (and each field in the pattern + -- will generate an error below). \end{code} %************************************************************************ %* * -\subsection{Subsumption} + Type refinement %* * %************************************************************************ -Example: - f :: (forall a. a->a) -> Int -> Int - f (g::Int->Int) y = g y -This is ok: the type signature allows fewer callers than -the (more general) signature f :: (Int->Int) -> Int -> Int -I.e. (forall a. a->a) <= Int -> Int -We end up translating this to: - f = \g' :: (forall a. a->a). let g = g' Int in g' y - -tcSubPat does the work - sig_ty is the signature on the pattern itself - (Int->Int in the example) - expected_ty is the type passed inwards from the context - (forall a. a->a in the example) - \begin{code} -tcSubPat :: TcSigmaType -> Expected TcSigmaType -> TcM PatCoFn - -tcSubPat sig_ty exp_ty - = tcSubOff sig_ty exp_ty `thenM` \ co_fn -> - -- co_fn is a coercion on *expressions*, and we - -- need to make a coercion on *patterns* - if isIdCoercion co_fn then - returnM idCoercion - else - newUnique `thenM` \ uniq -> - readExpectedType exp_ty `thenM` \ exp_ty' -> - let - arg_id = mkSysLocal FSLIT("sub") uniq exp_ty' - the_fn = DictLam [arg_id] (noLoc (co_fn <$> HsVar arg_id)) - pat_co_fn p = SigPatOut (noLoc p) exp_ty' the_fn - in - returnM (mkCoercion pat_co_fn) +refineAlt :: PatCtxt -> DataCon + -> [TcTyVar] -- Freshly bound type variables + -> [TcType] -- Types from the scrutinee (context) + -> [TcType] -- Types from the pattern + -> TcM a -> TcM a +refineAlt ctxt con ex_tvs ctxt_tys pat_tys thing_inside + = do { old_subst <- getTypeRefinement + ; let refiner | can_i_refine ctxt = tcRefineTys + | otherwise = tcMatchTys + ; case refiner ex_tvs old_subst pat_tys ctxt_tys of + Failed msg -> failWithTc (inaccessibleAlt msg) + Succeeded new_subst -> do + { traceTc (text "refineTypes:match" <+> ppr con <+> ppr new_subst) + ; setTypeRefinement new_subst thing_inside } } + + where + can_i_refine (LamPat can_refine) = can_refine + can_i_refine other_ctxt = False \end{code} +%************************************************************************ +%* * + Note [Pattern coercions] +%* * +%************************************************************************ + +In principle, these program would be reasonable: + + f :: (forall a. a->a) -> Int + f (x :: Int->Int) = x 3 + + g :: (forall a. [a]) -> Bool + g [] = True + +In both cases, the function type signature restricts what arguments can be passed +in a call (to polymorphic ones). The pattern type signature then instantiates this +type. For example, in the first case, (forall a. a->a) <= Int -> Int, and we +generate the translated term + f = \x' :: (forall a. a->a). let x = x' Int in x 3 + +From a type-system point of view, this is perfectly fine, but it's *very* seldom useful. +And it requires a significant amount of code to implement, becuase we need to decorate +the translated pattern with coercion functions (generated from the subsumption check +by tcSub). + +So for now I'm just insisting on type *equality* in patterns. No subsumption. + +Old notes about desugaring, at a time when pattern coercions were handled: + +A SigPat is a type coercion and must be handled one at at time. We can't +combine them unless the type of the pattern inside is identical, and we don't +bother to check for that. For example: + + data T = T1 Int | T2 Bool + f :: (forall a. a -> a) -> T -> t + f (g::Int->Int) (T1 i) = T1 (g i) + f (g::Bool->Bool) (T2 b) = T2 (g b) + +We desugar this as follows: + + f = \ g::(forall a. a->a) t::T -> + let gi = g Int + in case t of { T1 i -> T1 (gi i) + other -> + let gb = g Bool + in case t of { T2 b -> T2 (gb b) + other -> fail }} + +Note that we do not treat the first column of patterns as a +column of variables, because the coerced variables (gi, gb) +would be of different types. So we get rather grotty code. +But I don't think this is a common case, and if it was we could +doubtless improve it. + +Meanwhile, the strategy is: + * treat each SigPat coercion (always non-identity coercions) + as a separate block + * deal with the stuff inside, and then wrap a binding round + the result to bind the new variable (gi, gb, etc) + %************************************************************************ %* * @@ -487,8 +569,12 @@ tcSubPat sig_ty exp_ty %************************************************************************ \begin{code} -patCtxt pat = hang (ptext SLIT("When checking the pattern:")) - 4 (ppr pat) +patCtxt :: Pat Name -> Maybe Message -- Not all patterns are worth pushing a context +patCtxt (VarPat _) = Nothing +patCtxt (ParPat _) = Nothing +patCtxt (AsPat _ _) = Nothing +patCtxt pat = Just (hang (ptext SLIT("When checking the pattern:")) + 4 (ppr pat)) badFieldCon :: DataCon -> Name -> SDoc badFieldCon con field @@ -501,5 +587,14 @@ polyPatSig sig_ty 4 (ppr sig_ty) badTypePat pat = ptext SLIT("Illegal type pattern") <+> ppr pat -\end{code} +lazyPatErr pat tvs + = failWithTc $ + hang (ptext SLIT("A lazy (~) pattern connot bind existential type variables")) + 2 (vcat (map get tvs)) + where + get tv = ASSERT( isSkolemTyVar tv ) pprSkolemTyVar tv + +inaccessibleAlt msg + = hang (ptext SLIT("Inaccessible case alternative:")) 2 msg +\end{code} diff --git a/ghc/compiler/typecheck/TcRnDriver.lhs b/ghc/compiler/typecheck/TcRnDriver.lhs index 57da566c96..89909357cb 100644 --- a/ghc/compiler/typecheck/TcRnDriver.lhs +++ b/ghc/compiler/typecheck/TcRnDriver.lhs @@ -33,7 +33,7 @@ import RdrName ( RdrName, mkRdrUnqual, emptyGlobalRdrEnv, import TcHsSyn ( zonkTopDecls ) import TcExpr ( tcInferRho ) import TcRnMonad -import TcType ( tidyTopType, isUnLiftedType ) +import TcType ( tidyTopType ) import Inst ( showLIE ) import TcBinds ( tcTopBinds ) import TcDefaults ( tcDefaults ) @@ -41,7 +41,7 @@ import TcEnv ( tcExtendGlobalValEnv ) import TcRules ( tcRules ) import TcForeign ( tcForeignImports, tcForeignExports ) import TcInstDcls ( tcInstDecls1, tcInstDecls2 ) -import TcIface ( tcExtCoreBindings, loadImportedInsts ) +import TcIface ( tcExtCoreBindings ) import TcSimplify ( tcSimplifyTop ) import TcTyClsDecls ( tcTyAndClassDecls ) import LoadIface ( loadOrphanModules ) @@ -56,13 +56,13 @@ import Id ( mkExportedLocalId, isLocalId, idName, idType ) import Var ( Var ) import Module ( mkHomeModule, mkModuleName, moduleName, moduleEnvElts ) import OccName ( mkVarOcc ) -import Name ( Name, isExternalName, getSrcLoc, getOccName, nameSrcLoc ) +import Name ( Name, isExternalName, getSrcLoc, getOccName ) import NameSet import TyCon ( tyConHasGenerics ) -import SrcLoc ( SrcLoc, srcLocSpan, Located(..), noLoc ) +import SrcLoc ( srcLocSpan, Located(..), noLoc ) import Outputable -import HscTypes ( ModGuts(..), HscEnv(..), ExternalPackageState( eps_is_boot ), - GhciMode(..), isOneShot, Dependencies(..), noDependencies, +import HscTypes ( ModGuts(..), HscEnv(..), ExternalPackageState(..), + GhciMode(..), noDependencies, isOneShot, Deprecs( NoDeprecs ), plusDeprecs, ForeignStubs(NoStubs), TypeEnv, extendTypeEnvWithIds, typeEnvIds, typeEnvTyCons, @@ -70,7 +70,7 @@ import HscTypes ( ModGuts(..), HscEnv(..), ExternalPackageState( eps_is_boot ), ) #ifdef GHCI import HsSyn ( HsStmtContext(..), Stmt(..), HsExpr(..), HsBindGroup(..), - LStmt, LHsExpr, LHsType, + LStmt, LHsExpr, LHsType, mkMatchGroup, collectStmtsBinders, mkSimpleMatch, placeHolderType, nlLetStmt, nlExprStmt, nlBindStmt, nlResultStmt, nlVarPat ) import RdrName ( GlobalRdrEnv, mkGlobalRdrEnv, GlobalRdrElt(..), @@ -80,10 +80,13 @@ import RnSource ( addTcgDUs ) import TcHsSyn ( mkHsLet, zonkTopLExpr, zonkTopBndrs ) import TcHsType ( kcHsType ) import TcExpr ( tcCheckRho ) +import TcIface ( loadImportedInsts ) import TcMType ( zonkTcType ) +import TcUnify ( unifyTyConApp ) import TcMatches ( tcStmtsAndThen, TcStmtCtxt(..) ) import TcSimplify ( tcSimplifyInteractive, tcSimplifyInfer ) -import TcType ( Type, mkForAllTys, mkFunTys, mkTyConApp, tyVarsOfType, tyClsNamesOfDFunHead ) +import TcType ( Type, mkForAllTys, mkFunTys, mkTyConApp, tyVarsOfType, + isUnLiftedType, tyClsNamesOfDFunHead ) import TcEnv ( tcLookupTyCon, tcLookupId, tcLookupGlobal ) import RnTypes ( rnLHsType ) import Inst ( tcStdSyntaxName, tcGetInstEnvs ) @@ -96,7 +99,6 @@ import IfaceSyn ( IfaceDecl(..), IfaceClassOp(..), IfaceConDecl(..), tyThingToIfaceDecl, dfunToIfaceInst ) import RnEnv ( lookupOccRn, dataTcOccs, lookupFixityRn ) import Id ( Id, isImplicitId, globalIdDetails ) -import FieldLabel ( fieldLabelTyCon ) import MkId ( unsafeCoerceId ) import DataCon ( dataConTyCon ) import TyCon ( tyConName ) @@ -112,11 +114,12 @@ import Module ( ModuleName, lookupModuleEnvByName ) import HscTypes ( InteractiveContext(..), ExternalPackageState( eps_PTE ), HomeModInfo(..), typeEnvElts, typeEnvClasses, TyThing(..), availName, availNames, icPrintUnqual, - ModIface(..), ModDetails(..) ) + ModIface(..), ModDetails(..), Dependencies(..) ) import BasicTypes ( RecFlag(..), Fixity ) import Bag ( unitBag ) import ListSetOps ( removeDups ) import Panic ( ghcError, GhcException(..) ) +import SrcLoc ( SrcLoc ) #endif import FastString ( mkFastString ) @@ -151,7 +154,7 @@ tcRnModule hsc_env (L loc (HsModule maybe_mod exports -- The normal case initTc hsc_env this_mod $ - addSrcSpan loc $ + setSrcSpan loc $ do { -- Deal with imports; sets tcg_rdr_env, tcg_imports (rdr_env, imports) <- rnImports import_decls ; @@ -572,7 +575,7 @@ check_main ghci_mode tcg_env main_mod main_fn { let { rhs = nlHsApp (nlHsVar runIOName) (nlHsVar main_name) } -- :Main.main :: IO () = runIO main - ; (main_expr, ty) <- addSrcSpan (srcLocSpan (getSrcLoc main_name)) $ + ; (main_expr, ty) <- setSrcSpan (srcLocSpan (getSrcLoc main_name)) $ tcInferRho rhs ; let { root_main_id = mkExportedLocalId rootMainName ty ; @@ -706,7 +709,7 @@ tcUserStmt (L _ (ExprStmt expr _)) let fresh_it = itName uniq the_bind = noLoc $ FunBind (noLoc fresh_it) False - [ mkSimpleMatch [] expr placeHolderType ] + (mkMatchGroup [mkSimpleMatch [] expr]) in tryTcLIE_ (do { -- Try this if the other fails traceTc (text "tcs 1b") ; @@ -731,12 +734,14 @@ tc_stmts stmts names = map unLoc (collectStmtsBinders stmts) ; stmt_ctxt = SC { sc_what = DoExpr, - sc_rhs = check_rhs, + sc_rhs = infer_rhs, sc_body = check_body, sc_ty = ret_ty } ; - check_rhs rhs rhs_ty = tcCheckRho rhs (mkTyConApp ioTyCon [rhs_ty]) ; - check_body body = tcCheckRho body io_ret_ty ; + infer_rhs rhs = do { (rhs', rhs_ty) <- tcInferRho rhs + ; [pat_ty] <- unifyTyConApp ioTyCon rhs_ty + ; return (rhs', pat_ty) } ; + check_body body = tcCheckRho body io_ret_ty ; -- mk_return builds the expression -- returnIO @ [()] [coerce () x, .., coerce () z] @@ -927,16 +932,16 @@ getModuleContents hsc_env ictxt mod exports_only --------------------- filter_decl occs decl@(IfaceClass {ifSigs = sigs}) = decl { ifSigs = filter (keep_sig occs) sigs } -filter_decl occs decl@(IfaceData {ifCons = IfDataTyCon cons}) - = decl { ifCons = IfDataTyCon (filter (keep_con occs) cons) } +filter_decl occs decl@(IfaceData {ifCons = IfDataTyCon th cons}) + = decl { ifCons = IfDataTyCon th (filter (keep_con occs) cons) } filter_decl occs decl@(IfaceData {ifCons = IfNewTyCon con}) | keep_con occs con = decl | otherwise = decl {ifCons = IfAbstractTyCon} -- Hmm? filter_decl occs decl = decl -keep_sig occs (IfaceClassOp occ _ _) = occ `elem` occs -keep_con occs (IfaceConDecl occ _ _ _ _ _ _) = occ `elem` occs +keep_sig occs (IfaceClassOp occ _ _) = occ `elem` occs +keep_con occs con = ifConOcc con `elem` occs availOccs avail = map nameOccName (availNames avail) @@ -1048,9 +1053,9 @@ toIfaceDecl thing -- munge transforms a thing to it's "parent" thing munge (ADataCon dc) = ATyCon (dataConTyCon dc) munge (AnId id) = case globalIdDetails id of - RecordSelId lbl -> ATyCon (fieldLabelTyCon lbl) - ClassOpId cls -> AClass cls - other -> AnId id + RecordSelId tc lbl -> ATyCon tc + ClassOpId cls -> AClass cls + other -> AnId id munge other_thing = other_thing #endif /* GHCI */ diff --git a/ghc/compiler/typecheck/TcRnMonad.lhs b/ghc/compiler/typecheck/TcRnMonad.lhs index e2611e312f..a2db330dc1 100644 --- a/ghc/compiler/typecheck/TcRnMonad.lhs +++ b/ghc/compiler/typecheck/TcRnMonad.lhs @@ -1,4 +1,4 @@ -\begin{code} + \begin{code} module TcRnMonad( module TcRnMonad, module TcRnTypes, @@ -10,13 +10,14 @@ module TcRnMonad( import TcRnTypes -- Re-export all import IOEnv -- Re-export all +import HsSyn ( emptyLHsBinds ) import HscTypes ( HscEnv(..), ModGuts(..), ModIface(..), - TyThing, Dependencies(..), TypeEnv, emptyTypeEnv, + TyThing, TypeEnv, emptyTypeEnv, ExternalPackageState(..), HomePackageTable, ModDetails(..), HomeModInfo(..), Deprecs(..), FixityEnv, FixItem, GhciMode, lookupType, unQualInScope ) -import Module ( Module, ModuleName, unitModuleEnv, foldModuleEnv, emptyModuleEnv ) +import Module ( Module, ModuleName, unitModuleEnv, foldModuleEnv ) import RdrName ( GlobalRdrEnv, emptyGlobalRdrEnv, LocalRdrEnv, emptyLocalRdrEnv ) import Name ( Name, isInternalName ) @@ -25,9 +26,9 @@ import NameEnv ( extendNameEnvList ) import InstEnv ( InstEnv, emptyInstEnv, extendInstEnv ) import VarSet ( emptyVarSet ) -import VarEnv ( TidyEnv, emptyTidyEnv ) +import VarEnv ( TidyEnv, emptyTidyEnv, emptyVarEnv ) import ErrUtils ( Message, Messages, emptyMessages, errorsFound, - mkErrMsg, mkWarnMsg, printErrorsAndWarnings, + mkWarnMsg, printErrorsAndWarnings, mkLocMessage, mkLongErrMsg ) import SrcLoc ( mkGeneralSrcSpan, isGoodSrcSpan, SrcSpan, Located(..) ) import NameEnv ( emptyNameEnv ) @@ -90,7 +91,7 @@ initTc hsc_env mod do_this tcg_exports = emptyNameSet, tcg_imports = init_imports, tcg_dus = emptyDUs, - tcg_binds = emptyBag, + tcg_binds = emptyLHsBinds, tcg_deprecs = NoDeprecs, tcg_insts = [], tcg_rules = [], @@ -106,7 +107,8 @@ initTc hsc_env mod do_this tcl_arrow_ctxt = topArrowCtxt, tcl_env = emptyNameEnv, tcl_tyvars = tvs_var, - tcl_lie = panic "initTc:LIE" -- LIE only valid inside a getLIE + tcl_lie = panic "initTc:LIE", -- LIE only valid inside a getLIE + tcl_gadt = emptyVarEnv } ; } ; @@ -385,26 +387,26 @@ getSrcSpanM :: TcRn SrcSpan -- Avoid clash with Name.getSrcLoc getSrcSpanM = do { env <- getLclEnv; return (tcl_loc env) } -addSrcSpan :: SrcSpan -> TcRn a -> TcRn a -addSrcSpan loc thing_inside +setSrcSpan :: SrcSpan -> TcRn a -> TcRn a +setSrcSpan loc thing_inside | isGoodSrcSpan loc = updLclEnv (\env -> env { tcl_loc = loc }) thing_inside | otherwise = thing_inside -- Don't overwrite useful info with useless addLocM :: (a -> TcM b) -> Located a -> TcM b -addLocM fn (L loc a) = addSrcSpan loc $ fn a +addLocM fn (L loc a) = setSrcSpan loc $ fn a wrapLocM :: (a -> TcM b) -> Located a -> TcM (Located b) -wrapLocM fn (L loc a) = addSrcSpan loc $ do b <- fn a; return (L loc b) +wrapLocM fn (L loc a) = setSrcSpan loc $ do b <- fn a; return (L loc b) wrapLocFstM :: (a -> TcM (b,c)) -> Located a -> TcM (Located b, c) wrapLocFstM fn (L loc a) = - addSrcSpan loc $ do + setSrcSpan loc $ do (b,c) <- fn a return (L loc b, c) wrapLocSndM :: (a -> TcM (b,c)) -> Located a -> TcM (b, Located c) wrapLocSndM fn (L loc a) = - addSrcSpan loc $ do + setSrcSpan loc $ do (b,c) <- fn a return (b, L loc c) \end{code} @@ -595,25 +597,31 @@ failIfErrsM = ifErrsM failM (return ()) %************************************************************************ \begin{code} -setErrCtxtM, addErrCtxtM :: (TidyEnv -> TcM (TidyEnv, Message)) -> TcM a -> TcM a -setErrCtxtM msg = updCtxt (\ msgs -> [msg]) -addErrCtxtM msg = updCtxt (\ msgs -> msg : msgs) +getErrCtxt :: TcM ErrCtxt +getErrCtxt = do { env <- getLclEnv; return (tcl_ctxt env) } -setErrCtxt, addErrCtxt :: Message -> TcM a -> TcM a -setErrCtxt msg = setErrCtxtM (\env -> returnM (env, msg)) -addErrCtxt msg = addErrCtxtM (\env -> returnM (env, msg)) +setErrCtxt :: ErrCtxt -> TcM a -> TcM a +setErrCtxt ctxt = updLclEnv (\ env -> env { tcl_ctxt = ctxt }) -popErrCtxt :: TcM a -> TcM a -popErrCtxt = updCtxt (\ msgs -> case msgs of { [] -> []; (m:ms) -> ms }) +addErrCtxtM :: (TidyEnv -> TcM (TidyEnv, Message)) -> TcM a -> TcM a +addErrCtxtM msg = updCtxt (\ msgs -> msg : msgs) -getErrCtxt :: TcM ErrCtxt -getErrCtxt = do { env <- getLclEnv ; return (tcl_ctxt env) } +addErrCtxt :: Message -> TcM a -> TcM a +addErrCtxt msg = addErrCtxtM (\env -> returnM (env, msg)) -- Helper function for the above updCtxt :: (ErrCtxt -> ErrCtxt) -> TcM a -> TcM a updCtxt upd = updLclEnv (\ env@(TcLclEnv { tcl_ctxt = ctxt }) -> env { tcl_ctxt = upd ctxt }) +-- Conditionally add an error context +maybeAddErrCtxt :: Maybe Message -> TcM a -> TcM a +maybeAddErrCtxt (Just msg) thing_inside = addErrCtxt msg thing_inside +maybeAddErrCtxt Nothing thing_inside = thing_inside + +popErrCtxt :: TcM a -> TcM a +popErrCtxt = updCtxt (\ msgs -> case msgs of { [] -> []; (m:ms) -> ms }) + getInstLoc :: InstOrigin -> TcM InstLoc getInstLoc origin = do { loc <- getSrcSpanM ; env <- getLclEnv ; @@ -623,7 +631,7 @@ addInstCtxt :: InstLoc -> TcM a -> TcM a -- Add the SrcSpan and context from the first Inst in the list -- (they all have similar locations) addInstCtxt (InstLoc _ src_loc ctxt) thing_inside - = addSrcSpan src_loc (updCtxt (\ old_ctxt -> ctxt) thing_inside) + = setSrcSpan src_loc (updCtxt (\ old_ctxt -> ctxt) thing_inside) \end{code} The addErrTc functions add an error message, but do not cause failure. @@ -693,7 +701,18 @@ ctxt_to_use ctxt | opt_PprStyle_Debug = ctxt | otherwise = take 3 ctxt \end{code} -%************************************************************************ +debugTc is useful for monadi debugging code + +\begin{code} +debugTc :: TcM () -> TcM () +#ifdef DEBUG +debugTc thing = thing +#else +debugTc thing = return () +#endif +\end{code} + + %************************************************************************ %* * Type constraints (the so-called LIE) %* * @@ -914,3 +933,17 @@ forkM doc thing_inside Nothing -> pprPanic "forkM" doc Just r -> r) } \end{code} + +%************************************************************************ +%* * + Stuff for GADTs +%* * +%************************************************************************ + +\begin{code} +getTypeRefinement :: TcM GadtRefinement +getTypeRefinement = do { lcl_env <- getLclEnv; return (tcl_gadt lcl_env) } + +setTypeRefinement :: GadtRefinement -> TcM a -> TcM a +setTypeRefinement gadt = updLclEnv (\env -> env { tcl_gadt = gadt }) +\end{code} diff --git a/ghc/compiler/typecheck/TcRnTypes.lhs b/ghc/compiler/typecheck/TcRnTypes.lhs index c82c8b7a57..f563331acc 100644 --- a/ghc/compiler/typecheck/TcRnTypes.lhs +++ b/ghc/compiler/typecheck/TcRnTypes.lhs @@ -20,7 +20,7 @@ module TcRnTypes( WhereFrom(..), mkModDeps, -- Typechecker types - TcTyThing(..), + TcTyThing(..), GadtRefinement, -- Template Haskell ThStage(..), topStage, topSpliceStage, @@ -36,19 +36,20 @@ module TcRnTypes( plusLIEs, mkLIE, isEmptyLIE, lieToList, listToLIE, -- Misc other types - TcId, TcIdSet + TcId, TcIdSet, TcDictBinds ) where #include "HsVersions.h" -import HsSyn ( PendingSplice, HsOverLit, LHsBind, LRuleDecl, LForeignDecl, - Pat, ArithSeqInfo ) +import HsSyn ( PendingSplice, HsOverLit, LRuleDecl, LForeignDecl, + ArithSeqInfo, DictBinds, LHsBinds ) import HscTypes ( FixityEnv, HscEnv, TypeEnv, TyThing, - Avails, GenAvailInfo(..), AvailInfo, + GenAvailInfo(..), AvailInfo, availName, IsBootInterface, Deprecations ) import Packages ( PackageName ) -import TcType ( TcTyVarSet, TcType, TcTauType, TcThetaType, +import Type ( Type, TvSubstEnv ) +import TcType ( TcTyVarSet, TcType, TcTauType, TcThetaType, SkolemInfo, TcPredType, TcKind, tcCmpPred, tcCmpType, tcCmpTypes ) import InstEnv ( DFunId, InstEnv ) import IOEnv @@ -57,8 +58,6 @@ import Name ( Name ) import NameEnv import NameSet ( NameSet, emptyNameSet, DefUses ) import OccName ( OccEnv ) -import Type ( Type ) -import Class ( Class ) import Var ( Id, TyVar ) import VarEnv ( TidyEnv ) import Module @@ -85,9 +84,12 @@ import ListSetOps ( unionLists ) The monad itself has to be defined here, because it is mentioned by ErrCtxt \begin{code} -type TcRef a = IORef a -type TcId = Id -- Type may be a TcType -type TcIdSet = IdSet +type TcRef a = IORef a +type TcId = Id -- Type may be a TcType +type TcIdSet = IdSet +type TcDictBinds = DictBinds TcId -- Bag of dictionary bindings + + type TcRnIf a b c = IOEnv (Env a b) c type IfM lcl a = TcRnIf IfGblEnv lcl a -- Iface stuff @@ -187,7 +189,7 @@ data TcGblEnv -- The next fields accumulate the payload of the module -- The binds, rules and foreign-decl fiels are collected -- initially in un-zonked form and are finally zonked in tcRnSrcDecls - tcg_binds :: Bag (LHsBind Id), -- Value bindings in this module + tcg_binds :: LHsBinds Id, -- Value bindings in this module tcg_deprecs :: Deprecations, -- ...Deprecations tcg_insts :: [DFunId], -- ...Instances tcg_rules :: [LRuleDecl Id], -- ...Rules @@ -273,9 +275,11 @@ data TcLclEnv -- Changes as we move inside an expression -- We still need the unsullied global name env so that -- we can look up record field names - tcl_env :: NameEnv TcTyThing, -- The local type environment: Ids and TyVars - -- defined in this module + tcl_env :: NameEnv TcTyThing, -- The local type environment: Ids and TyVars + -- defined in this module + tcl_gadt :: GadtRefinement, -- The current type refinement for GADTs + tcl_tyvars :: TcRef TcTyVarSet, -- The "global tyvars" -- Namely, the in-scope TyVars bound in tcl_lenv, -- plus the tyvars mentioned in the types of Ids bound in tcl_lenv @@ -284,6 +288,9 @@ data TcLclEnv -- Changes as we move inside an expression tcl_lie :: TcRef LIE -- Place to accumulate type constraints } +type GadtRefinement = TvSubstEnv -- Binds rigid type variables to their refinements + + --------------------------- -- Template Haskell levels --------------------------- @@ -638,7 +645,7 @@ data Inst -- type of (f tys dicts(from theta)) = tau -- INVARIANT 2: tau must not be of form (Pred -> Tau) - -- Reason: two methods are considerd equal if the + -- Reason: two methods are considered equal if the -- base Id matches, and the instantiating types -- match. The TcThetaType should then match too. -- This only bites in the call to tcInstClassOp in TcClassDcl.mkMethodBind @@ -723,91 +730,54 @@ instLocSrcSpan :: InstLoc -> SrcSpan instLocSrcSpan (InstLoc _ src_span _) = src_span data InstOrigin - = OccurrenceOf Name -- Occurrence of an overloaded identifier + = SigOrigin SkolemInfo -- Pattern, class decl, inst decl etc; + -- Places that bind type variables and introduce + -- available constraints - | IPOccOrigin (IPName Name) -- Occurrence of an implicit parameter | IPBindOrigin (IPName Name) -- Binding site of an implicit parameter - | RecordUpdOrigin - - | DataDeclOrigin -- Typechecking a data declaration + ------------------------------------------------------- + -- The rest are all occurrences: Insts that are 'wanted' + ------------------------------------------------------- + | OccurrenceOf Name -- Occurrence of an overloaded identifier - | InstanceDeclOrigin -- Typechecking an instance decl + | IPOccOrigin (IPName Name) -- Occurrence of an implicit parameter | LiteralOrigin HsOverLit -- Occurrence of a literal - | PatOrigin (Pat Name) - | ArithSeqOrigin (ArithSeqInfo Name) -- [x..], [x..y] etc | PArrSeqOrigin (ArithSeqInfo Name) -- [:x..y:] and [:x,y..z:] - | SignatureOrigin -- A dict created from a type signature - | Rank2Origin -- A dict created when typechecking the argument - -- of a rank-2 typed function - - | DoOrigin -- The monad for a do expression - | ProcOrigin -- A proc expression - - | ClassDeclOrigin -- Manufactured during a class decl - - | InstanceSpecOrigin Class -- in a SPECIALIZE instance pragma - Type + | InstSigOrigin -- A dict occurrence arising from instantiating + -- a polymorphic type during a subsumption check - -- When specialising instances the instance info attached to - -- each class is not yet ready, so we record it inside the - -- origin information. This is a bit of a hack, but it works - -- fine. (Patrick is to blame [WDP].) - - | ValSpecOrigin Name -- in a SPECIALIZE pragma for a value - - -- Argument or result of a ccall - -- Dictionaries with this origin aren't actually mentioned in the - -- translated term, and so need not be bound. Nor should they - -- be abstracted over. - - | UnknownOrigin -- Help! I give up... + | RecordUpdOrigin + | InstScOrigin -- Typechecking superclasses of an instance declaration + | DerivOrigin -- Typechecking deriving + | DefaultOrigin -- Typechecking a default decl + | DoOrigin -- Arising from a do expression + | ProcOrigin -- Arising from a proc expression \end{code} \begin{code} pprInstLoc :: InstLoc -> SDoc -pprInstLoc (InstLoc orig locn ctxt) +pprInstLoc (InstLoc (SigOrigin info) locn _) + = text "arising from" <+> ppr info -- I don't think this happens much, if at all +pprInstLoc (InstLoc orig locn _) = hsep [text "arising from", pp_orig orig, text "at", ppr locn] where - pp_orig (OccurrenceOf name) - = hsep [ptext SLIT("use of"), quotes (ppr name)] - pp_orig (IPOccOrigin name) - = hsep [ptext SLIT("use of implicit parameter"), quotes (ppr name)] - pp_orig (IPBindOrigin name) - = hsep [ptext SLIT("binding for implicit parameter"), quotes (ppr name)] - pp_orig RecordUpdOrigin - = ptext SLIT("a record update") - pp_orig DataDeclOrigin - = ptext SLIT("the data type declaration") - pp_orig InstanceDeclOrigin - = ptext SLIT("the instance declaration") - pp_orig (LiteralOrigin lit) - = hsep [ptext SLIT("the literal"), quotes (ppr lit)] - pp_orig (PatOrigin pat) - = hsep [ptext SLIT("the pattern"), quotes (ppr pat)] - pp_orig (ArithSeqOrigin seq) - = hsep [ptext SLIT("the arithmetic sequence"), quotes (ppr seq)] - pp_orig (PArrSeqOrigin seq) - = hsep [ptext SLIT("the parallel array sequence"), quotes (ppr seq)] - pp_orig (SignatureOrigin) - = ptext SLIT("a type signature") - pp_orig (Rank2Origin) - = ptext SLIT("a function with an overloaded argument type") - pp_orig (DoOrigin) - = ptext SLIT("a do statement") - pp_orig (ProcOrigin) - = ptext SLIT("a proc expression") - pp_orig (ClassDeclOrigin) - = ptext SLIT("a class declaration") - pp_orig (InstanceSpecOrigin clas ty) - = hsep [text "a SPECIALIZE instance pragma; class", - quotes (ppr clas), text "type:", ppr ty] - pp_orig (ValSpecOrigin name) - = hsep [ptext SLIT("a SPECIALIZE user-pragma for"), quotes (ppr name)] - pp_orig (UnknownOrigin) - = ptext SLIT("...oops -- I don't know where the overloading came from!") + pp_orig (OccurrenceOf name) = hsep [ptext SLIT("use of"), quotes (ppr name)] + pp_orig (IPOccOrigin name) = hsep [ptext SLIT("use of implicit parameter"), quotes (ppr name)] + pp_orig (IPBindOrigin name) = hsep [ptext SLIT("binding for implicit parameter"), quotes (ppr name)] + pp_orig RecordUpdOrigin = ptext SLIT("a record update") + pp_orig (LiteralOrigin lit) = hsep [ptext SLIT("the literal"), quotes (ppr lit)] + pp_orig (ArithSeqOrigin seq) = hsep [ptext SLIT("the arithmetic sequence"), quotes (ppr seq)] + pp_orig (PArrSeqOrigin seq) = hsep [ptext SLIT("the parallel array sequence"), quotes (ppr seq)] + pp_orig InstSigOrigin = ptext SLIT("instantiating a type signature") + pp_orig InstScOrigin = ptext SLIT("the superclasses of an instance declaration") + pp_orig DerivOrigin = ptext SLIT("the 'deriving' clause of a data type declaration") + pp_orig DefaultOrigin = ptext SLIT("a 'default' declaration") + pp_orig DoOrigin = ptext SLIT("a do statement") + pp_orig ProcOrigin = ptext SLIT("a proc expression") + pp_orig (SigOrigin info) = ppr info \end{code} diff --git a/ghc/compiler/typecheck/TcRules.lhs b/ghc/compiler/typecheck/TcRules.lhs index 4fc001714a..d78003b487 100644 --- a/ghc/compiler/typecheck/TcRules.lhs +++ b/ghc/compiler/typecheck/TcRules.lhs @@ -8,14 +8,14 @@ module TcRules ( tcRules ) where #include "HsVersions.h" -import HsSyn ( RuleDecl(..), LRuleDecl, RuleBndr(..), collectRuleBndrSigTys, mkHsLet ) +import HsSyn ( RuleDecl(..), LRuleDecl, RuleBndr(..), mkHsLet ) import TcRnMonad import TcSimplify ( tcSimplifyToDicts, tcSimplifyInferCheck ) -import TcMType ( newTyVarTy ) +import TcMType ( newTyFlexiVarTy, zonkQuantifiedTyVar ) import TcType ( tyVarsOfTypes, openTypeKind ) -import TcHsType ( tcHsSigType, UserTypeCtxt(..), tcAddScopedTyVars ) +import TcHsType ( UserTypeCtxt(..), tcHsPatSigType ) import TcExpr ( tcCheckRho ) -import TcEnv ( tcExtendLocalValEnv ) +import TcEnv ( tcExtendIdEnv, tcExtendTyVarEnv ) import Inst ( instToId ) import Id ( idType, mkLocalId ) import Name ( Name ) @@ -32,19 +32,13 @@ tcRule (HsRule name act vars lhs rhs) = addErrCtxt (ruleCtxt name) $ traceTc (ptext SLIT("---- Rule ------") <+> ppr name) `thenM_` - newTyVarTy openTypeKind `thenM` \ rule_ty -> + newTyFlexiVarTy openTypeKind `thenM` \ rule_ty -> -- Deal with the tyvars mentioned in signatures - tcAddScopedTyVars (collectRuleBndrSigTys vars) ( - - -- Ditto forall'd variables - mappM new_id vars `thenM` \ ids -> - tcExtendLocalValEnv ids $ - + tcRuleBndrs vars (\ ids -> -- Now LHS and RHS getLIE (tcCheckRho lhs rule_ty) `thenM` \ (lhs', lhs_lie) -> getLIE (tcCheckRho rhs rule_ty) `thenM` \ (rhs', rhs_lie) -> - returnM (ids, lhs', rhs', lhs_lie, rhs_lie) ) `thenM` \ (ids, lhs', rhs', lhs_lie, rhs_lie) -> @@ -85,18 +79,27 @@ tcRule (HsRule name act vars lhs rhs) tcSimplifyInferCheck (text "tcRule") forall_tvs lhs_dicts rhs_lie `thenM` \ (forall_tvs1, rhs_binds) -> + mappM zonkQuantifiedTyVar forall_tvs1 `thenM` \ forall_tvs2 -> + -- This zonk is exactly the same as the one in TcBinds.tcBindWithSigs returnM (HsRule name act - (map (RuleBndr . noLoc) (forall_tvs1 ++ tpl_ids)) -- yuk + (map (RuleBndr . noLoc) (forall_tvs2 ++ tpl_ids)) -- yuk (mkHsLet lhs_binds lhs') (mkHsLet rhs_binds rhs')) where - new_id (RuleBndr var) = newTyVarTy openTypeKind `thenM` \ ty -> - returnM (mkLocalId (unLoc var) ty) - new_id (RuleBndrSig var rn_ty) = tcHsSigType (RuleSigCtxt nl_var) rn_ty `thenM` \ ty -> - returnM (mkLocalId nl_var ty) - where - nl_var = unLoc var + +tcRuleBndrs [] thing_inside = thing_inside [] +tcRuleBndrs (RuleBndr var : vars) thing_inside + = do { ty <- newTyFlexiVarTy openTypeKind + ; let id = mkLocalId (unLoc var) ty + ; tcExtendIdEnv [id] $ + tcRuleBndrs vars (\ids -> thing_inside (id:ids)) } +tcRuleBndrs (RuleBndrSig var rn_ty : vars) thing_inside + = do { (tyvars, ty) <- tcHsPatSigType (RuleSigCtxt (unLoc var)) rn_ty + ; let id = mkLocalId (unLoc var) ty + ; tcExtendTyVarEnv tyvars $ + tcExtendIdEnv [id] $ + tcRuleBndrs vars (\ids -> thing_inside (id:ids)) } ruleCtxt name = ptext SLIT("When checking the transformation rule") <+> doubleQuotes (ftext name) diff --git a/ghc/compiler/typecheck/TcSimplify.lhs b/ghc/compiler/typecheck/TcSimplify.lhs index 1a7e204d65..f24b5ded57 100644 --- a/ghc/compiler/typecheck/TcSimplify.lhs +++ b/ghc/compiler/typecheck/TcSimplify.lhs @@ -21,7 +21,7 @@ module TcSimplify ( import {-# SOURCE #-} TcUnify( unifyTauTy ) import TcEnv -- temp -import HsSyn ( HsBind(..), LHsBinds, HsExpr(..), LHsExpr, pprLHsBinds ) +import HsSyn ( HsBind(..), HsExpr(..), LHsExpr, emptyLHsBinds ) import TcHsSyn ( TcId, TcDictBinds, mkHsApp, mkHsTyApp, mkHsDictApp ) import TcRnMonad @@ -41,8 +41,8 @@ import Inst ( lookupInst, LookupInstResult(..), import TcEnv ( tcGetGlobalTyVars, tcLookupId, findGlobals ) import InstEnv ( lookupInstEnv, classInstances ) import TcMType ( zonkTcTyVarsAndFV, tcInstTyVars, checkAmbiguity ) -import TcType ( TcTyVar, TcTyVarSet, ThetaType, TyVarDetails(VanillaTv), - mkClassPred, isOverloadedTy, mkTyConApp, +import TcType ( TcTyVar, TcTyVarSet, ThetaType, + mkClassPred, isOverloadedTy, mkTyConApp, mkTyVarTy, tcGetTyVar, isTyVarClassPred, mkTyVarTys, tyVarsOfPred, tcEqType, pprPred ) import Id ( idType, mkUserLocal ) @@ -54,7 +54,7 @@ import FunDeps ( oclose, grow, improve, pprEquationDoc ) import PrelInfo ( isNumericClass ) import PrelNames ( splitName, fstName, sndName, integerTyConName, showClassKey, eqClassKey, ordClassKey ) -import Subst ( mkTopTyVarSubst, substTheta, substTy ) +import Type ( zipTopTvSubst, substTheta, substTy ) import TysWiredIn ( pairTyCon, doubleTy ) import ErrUtils ( Message ) import VarSet @@ -651,7 +651,8 @@ inferLoop doc tau_tvs wanteds | isClassDict inst = DontReduceUnlessConstant -- Dicts | otherwise = ReduceMe -- Lits and Methods in - traceTc (text "infloop" <+> vcat [ppr tau_tvs', ppr wanteds', ppr preds, ppr (grow preds tau_tvs'), ppr qtvs]) `thenM_` + traceTc (text "infloop" <+> vcat [ppr tau_tvs', ppr wanteds', ppr preds, + ppr (grow preds tau_tvs'), ppr qtvs]) `thenM_` -- Step 2 reduceContext doc try_me [] wanteds' `thenM` \ (no_improvement, frees, binds, irreds) -> @@ -765,7 +766,8 @@ tcSimplifyCheck doc qtvs givens wanted_lie givens wanted_lie `thenM` \ (qtvs', binds) -> returnM binds where - get_qtvs = zonkTcTyVarsAndFV qtvs +-- get_qtvs = zonkTcTyVarsAndFV qtvs + get_qtvs = return (mkVarSet qtvs) -- tcSimplifyInferCheck is used when we know the constraints we are to simplify @@ -1170,30 +1172,37 @@ For each method @Inst@ in the @init_lie@ that mentions one of the @LIE@), as well as the @HsBinds@ generated. \begin{code} -bindInstsOfLocalFuns :: [Inst] -> [TcId] -> TcM (LHsBinds TcId) +bindInstsOfLocalFuns :: [Inst] -> [TcId] -> TcM TcDictBinds +-- Simlifies only MethodInsts, and generate only bindings of form +-- fm = f tys dicts +-- We're careful not to even generate bindings of the form +-- d1 = d2 +-- You'd think that'd be fine, but it interacts with what is +-- arguably a bug in Match.tidyEqnInfo (see notes there) bindInstsOfLocalFuns wanteds local_ids | null overloaded_ids -- Common case = extendLIEs wanteds `thenM_` - returnM emptyBag + returnM emptyLHsBinds | otherwise - = simpleReduceLoop doc try_me wanteds `thenM` \ (frees, binds, irreds) -> + = simpleReduceLoop doc try_me for_me `thenM` \ (frees, binds, irreds) -> ASSERT( null irreds ) + extendLIEs not_for_me `thenM_` extendLIEs frees `thenM_` returnM binds where doc = text "bindInsts" <+> ppr local_ids overloaded_ids = filter is_overloaded local_ids is_overloaded id = isOverloadedTy (idType id) + (for_me, not_for_me) = partition (isMethodFor overloaded_set) wanteds overloaded_set = mkVarSet overloaded_ids -- There can occasionally be a lot of them -- so it's worth building a set, so that -- lookup (in isMethodFor) is faster - - try_me inst | isMethodFor overloaded_set inst = ReduceMe - | otherwise = Free + try_me inst | isMethod inst = ReduceMe + | otherwise = Free \end{code} @@ -1562,8 +1571,8 @@ tcImprove avails returnM False where unify ((qtvs, pairs), doc) - = addErrCtxt doc $ - tcInstTyVars VanillaTv (varSetElems qtvs) `thenM` \ (_, _, tenv) -> + = addErrCtxt doc $ + tcInstTyVars (varSetElems qtvs) `thenM` \ (_, _, tenv) -> mapM_ (unif_pr tenv) pairs unif_pr tenv (ty1,ty2) = unifyTauTy (substTy tenv ty1) (substTy tenv ty2) \end{code} @@ -1772,7 +1781,7 @@ addSCs is_loop avails dict where (clas, tys) = getDictClassTys dict (tyvars, sc_theta, sc_sels, _) = classBigSig clas - sc_theta' = substTheta (mkTopTyVarSubst tyvars tys) sc_theta + sc_theta' = substTheta (zipTopTvSubst tyvars tys) sc_theta add_sc avails (sc_dict, sc_sel) -- Add it, and its superclasses | add_me sc_dict = addSCs is_loop avails' sc_dict @@ -2116,11 +2125,11 @@ tcSimplifyDeriv :: [TyVar] -> TcM ThetaType -- Needed tcSimplifyDeriv tyvars theta - = tcInstTyVars VanillaTv tyvars `thenM` \ (tvs, _, tenv) -> + = tcInstTyVars tyvars `thenM` \ (tvs, _, tenv) -> -- The main loop may do unification, and that may crash if -- it doesn't see a TcTyVar, so we have to instantiate. Sigh -- ToDo: what if two of them do get unified? - newDicts DataDeclOrigin (substTheta tenv theta) `thenM` \ wanteds -> + newDicts DerivOrigin (substTheta tenv theta) `thenM` \ wanteds -> simpleReduceLoop doc reduceMe wanteds `thenM` \ (frees, _, irreds) -> ASSERT( null frees ) -- reduceMe never returns Free @@ -2152,7 +2161,7 @@ tcSimplifyDeriv tyvars theta -- of problems; in particular, it's hard to compare solutions for -- equality when finding the fixpoint. So I just rule it out for now. - rev_env = mkTopTyVarSubst tvs (mkTyVarTys tyvars) + rev_env = zipTopTvSubst tvs (mkTyVarTys tyvars) -- This reverse-mapping is a Royal Pain, -- but the result should mention TyVars not TcTyVars in @@ -2174,7 +2183,7 @@ tcSimplifyDefault :: ThetaType -- Wanted; has no type variables in it -> TcM () tcSimplifyDefault theta - = newDicts DataDeclOrigin theta `thenM` \ wanteds -> + = newDicts DefaultOrigin theta `thenM` \ wanteds -> simpleReduceLoop doc reduceMe wanteds `thenM` \ (frees, _, irreds) -> ASSERT( null frees ) -- try_me never returns Free addNoInstanceErrs Nothing [] irreds `thenM_` @@ -2330,7 +2339,7 @@ addTopAmbigErrs dicts report :: [(Inst,[TcTyVar])] -> TcM () report pairs@((inst,tvs) : _) -- The pairs share a common set of ambiguous tyvars = mkMonomorphismMsg tidy_env dicts `thenM` \ (tidy_env, mono_msg) -> - addSrcSpan (instLocSrcSpan (instLoc inst)) $ + setSrcSpan (instLocSrcSpan (instLoc inst)) $ -- the location of the first one will do for the err message addErrTcM (tidy_env, msg $$ mono_msg) where diff --git a/ghc/compiler/typecheck/TcSplice.lhs b/ghc/compiler/typecheck/TcSplice.lhs index 89d4a7aed1..66c0f57843 100644 --- a/ghc/compiler/typecheck/TcSplice.lhs +++ b/ghc/compiler/typecheck/TcSplice.lhs @@ -30,7 +30,7 @@ import TcSimplify ( tcSimplifyTop, tcSimplifyBracket ) import TcUnify ( Expected, zapExpectedTo, zapExpectedType ) import TcType ( TcType, TcKind, liftedTypeKind, mkAppTy, tcSplitSigmaTy ) import TcEnv ( spliceOK, tcMetaTy, bracketOK ) -import TcMType ( newTyVarTy, newKindVar, UserTypeCtxt(ExprSigCtxt), zonkTcType, zonkTcTyVar ) +import TcMType ( newTyFlexiVarTy, newKindVar, UserTypeCtxt(ExprSigCtxt), zonkTcType, zonkTcTyVar ) import TcHsType ( tcHsSigType, kcHsType ) import TcIface ( tcImportDecl ) import TypeRep ( Type(..), PredType(..), TyThing(..) ) -- For reification @@ -44,9 +44,11 @@ import Module ( moduleUserString, mkModuleName ) import TcRnMonad import IfaceEnv ( lookupOrig ) import Class ( Class, classBigSig ) -import TyCon ( TyCon, tyConTheta, tyConTyVars, getSynTyConDefn, isSynTyCon, isNewTyCon, tyConDataCons ) +import TyCon ( TyCon, AlgTyConRhs(..), tyConTyVars, getSynTyConDefn, + isSynTyCon, isNewTyCon, tyConDataCons, algTcRhs ) import DataCon ( DataCon, dataConTyCon, dataConOrigArgTys, dataConStrictMarks, - dataConName, dataConFieldLabels, dataConWrapId, dataConIsInfix ) + dataConName, dataConFieldLabels, dataConWrapId, dataConIsInfix, + isVanillaDataCon ) import Id ( idName, globalIdDetails ) import IdInfo ( GlobalIdDetails(..) ) import TysWiredIn ( mkListTy ) @@ -62,6 +64,7 @@ import FastString ( LitString ) import GHC.Base ( unsafeCoerce#, Int#, Int(..) ) -- Should have a better home in the module hierarchy import Monad ( liftM ) +import Maybes ( orElse ) #ifdef GHCI import FastString ( mkFastString ) @@ -126,8 +129,8 @@ tc_bracket (VarBr v) -- Result type is Var (not Q-monadic) tc_bracket (ExpBr expr) - = newTyVarTy liftedTypeKind `thenM` \ any_ty -> - tcCheckRho expr any_ty `thenM_` + = newTyFlexiVarTy liftedTypeKind `thenM` \ any_ty -> + tcCheckRho expr any_ty `thenM_` tcMetaTy expQTyConName -- Result type is Expr (= Q Exp) @@ -156,7 +159,7 @@ tc_bracket (DecBr decls) \begin{code} tcSpliceExpr (HsSplice name expr) res_ty - = addSrcSpan (getLoc expr) $ + = setSrcSpan (getLoc expr) $ getStage `thenM` \ level -> case spliceOK level of { Nothing -> failWithTc (illegalSplice level) ; @@ -256,7 +259,7 @@ Very like splicing an expression, but we don't yet share code. \begin{code} kcSpliceType (HsSplice name hs_expr) - = addSrcSpan (getLoc hs_expr) $ do + = setSrcSpan (getLoc hs_expr) $ do { level <- getStage ; case spliceOK level of { Nothing -> failWithTc (illegalSplice level) ; @@ -565,20 +568,22 @@ reifyTyCon tc ; rhs' <- reifyType rhs ; return (TH.TySynD (reifyName tc) (reifyTyVars tvs) rhs') } - | isNewTyCon tc - = do { cxt <- reifyCxt (tyConTheta tc) - ; con <- reifyDataCon (head (tyConDataCons tc)) - ; return (TH.NewtypeD cxt (reifyName tc) (reifyTyVars (tyConTyVars tc)) - con [{- Don't know about deriving -}]) } - - | otherwise -- Algebraic - = do { cxt <- reifyCxt (tyConTheta tc) - ; cons <- mapM reifyDataCon (tyConDataCons tc) - ; return (TH.DataD cxt (reifyName tc) (reifyTyVars (tyConTyVars tc)) - cons [{- Don't know about deriving -}]) } +reifyTyCon tc + = case algTcRhs tc of + NewTyCon data_con _ _ + -> do { con <- reifyDataCon data_con + ; return (TH.NewtypeD [] (reifyName tc) (reifyTyVars (tyConTyVars tc)) + con [{- Don't know about deriving -}]) } + + DataTyCon mb_cxt cons _ + -> do { cxt <- reifyCxt (mb_cxt `orElse` []) + ; cons <- mapM reifyDataCon (tyConDataCons tc) + ; return (TH.DataD cxt (reifyName tc) (reifyTyVars (tyConTyVars tc)) + cons [{- Don't know about deriving -}]) } reifyDataCon :: DataCon -> TcM TH.Con reifyDataCon dc + | isVanillaDataCon dc = do { arg_tys <- reifyTypes (dataConOrigArgTys dc) ; let stricts = map reifyStrict (dataConStrictMarks dc) fields = dataConFieldLabels dc @@ -594,6 +599,9 @@ reifyDataCon dc return (TH.InfixC (s1,a1) name (s1,a2)) else return (TH.NormalC name (stricts `zip` arg_tys)) } + | otherwise + = failWithTc (ptext SLIT("Can't reify a non-Haskell-98 data constructor:") + <+> quotes (ppr dc)) ------------------------------ reifyClass :: Class -> TcM TH.Dec diff --git a/ghc/compiler/typecheck/TcTyClsDecls.lhs b/ghc/compiler/typecheck/TcTyClsDecls.lhs index a03b349780..2be946e252 100644 --- a/ghc/compiler/typecheck/TcTyClsDecls.lhs +++ b/ghc/compiler/typecheck/TcTyClsDecls.lhs @@ -11,12 +11,13 @@ module TcTyClsDecls ( #include "HsVersions.h" import HsSyn ( TyClDecl(..), HsConDetails(..), HsTyVarBndr(..), - ConDecl(..), Sig(..), BangType(..), HsBang(..), NewOrData(..), - tyClDeclTyVars, getBangType, getBangStrictness, isSynDecl, - LTyClDecl, tcdName, LHsTyVarBndr + ConDecl(..), Sig(..), , NewOrData(..), + tyClDeclTyVars, isSynDecl, LConDecl, + LTyClDecl, tcdName, LHsTyVarBndr, LHsContext ) +import HsTypes ( HsBang(..), getBangStrictness ) import BasicTypes ( RecFlag(..), StrictnessMark(..) ) -import HscTypes ( implicitTyThings, lookupFixity ) +import HscTypes ( implicitTyThings ) import BuildTyCl ( buildClass, buildAlgTyCon, buildSynTyCon, buildDataCon, mkDataTyConRhs, mkNewTyConRhs ) import TcRnMonad @@ -26,22 +27,24 @@ import TcEnv ( TcTyThing(..), TyThing(..), tcExtendRecEnv, tcLookupTyVar ) import TcTyDecls ( calcTyConArgVrcs, calcRecFlags, calcClassCycles, calcSynCycles ) import TcClassDcl ( tcClassSigs, tcAddDeclCtxt ) -import TcHsType ( kcHsTyVars, kcHsLiftedSigType, kcHsSigType, kcHsType, - kcHsContext, tcTyVarBndrs, tcHsKindedType, tcHsKindedContext ) +import TcHsType ( kcHsTyVars, kcHsLiftedSigType, kcHsType, + kcHsContext, tcTyVarBndrs, tcHsKindedType, tcHsKindedContext, + kcHsSigType, tcHsBangType, tcLHsConSig ) import TcMType ( newKindVar, checkValidTheta, checkValidType, checkFreeness, UserTypeCtxt(..), SourceTyCtxt(..) ) import TcUnify ( unifyKind ) -import TcType ( TcKind, ThetaType, TcType, tyVarsOfType, - mkArrowKind, liftedTypeKind, +import TcType ( TcKind, ThetaType, TcType, tyVarsOfType, + mkArrowKind, liftedTypeKind, mkTyVarTys, tcEqTypes, tcSplitSigmaTy, tcEqType ) import Type ( splitTyConApp_maybe, pprThetaArrow, pprParendType ) -import FieldLabel ( fieldLabelName, fieldLabelType ) import Generics ( validGenericMethodType, canDoGenerics ) import Class ( Class, className, classTyCon, DefMeth(..), classBigSig, classTyVars ) import TyCon ( TyCon, ArgVrcs, tyConDataCons, mkForeignTyCon, isProductTyCon, isRecursiveTyCon, - tyConTheta, getSynTyConDefn, tyConDataCons, isSynTyCon, tyConName ) -import DataCon ( DataCon, dataConWrapId, dataConName, dataConSig, dataConFieldLabels ) + tyConStupidTheta, getSynTyConDefn, tyConDataCons, isSynTyCon, tyConName ) +import DataCon ( DataCon, dataConWrapId, dataConName, dataConSig, + dataConFieldLabels, dataConOrigArgTys, dataConTyCon ) +import Type ( zipTopTvSubst, substTys ) import Var ( TyVar, idType, idName ) import VarSet ( elemVarSet ) import Name ( Name ) @@ -274,6 +277,9 @@ kcTyClDecl decl@(TyData {tcdND = new_or_data, tcdCtxt = ctxt, tcdCons = cons}) do { ex_ctxt' <- kcHsContext ex_ctxt ; details' <- kc_con_details details ; return (ConDecl name ex_tvs' ex_ctxt' details')} + kc_con_decl (GadtDecl name ty) + = do { ty' <- kcHsSigType ty + ; return (GadtDecl name ty') } kc_con_details (PrefixCon btys) = do { btys' <- mappM kc_larg_ty btys ; return (PrefixCon btys') } @@ -284,14 +290,12 @@ kcTyClDecl decl@(TyData {tcdND = new_or_data, tcdCtxt = ctxt, tcdCons = cons}) kc_field (fld, bty) = do { bty' <- kc_larg_ty bty ; return (fld, bty') } - kc_larg_ty = wrapLocM kc_arg_ty - - kc_arg_ty (BangType str ty) = do { ty' <- kc_arg_ty_body ty; return (BangType str ty') } - kc_arg_ty_body = case new_or_data of - DataType -> kcHsSigType - NewType -> kcHsLiftedSigType - -- Can't allow an unlifted type for newtypes, because we're effectively - -- going to remove the constructor while coercing it to a lifted type. + kc_larg_ty bty = case new_or_data of + DataType -> kcHsSigType bty + NewType -> kcHsLiftedSigType bty + -- Can't allow an unlifted type for newtypes, because we're effectively + -- going to remove the constructor while coercing it to a lifted type. + -- And newtypes can't be bang'd kcTyClDecl decl@(ClassDecl {tcdCtxt = ctxt, tcdSigs = sigs}) = kcTyClDeclBody decl $ \ tvs' -> @@ -357,16 +361,16 @@ tcTyClDecl1 calc_vrcs calc_isrec (TyData {tcdND = new_or_data, tcdCtxt = ctxt, tcdTyVars = tvs, tcdLName = L _ tc_name, tcdCons = cons}) = tcTyVarBndrs tvs $ \ tvs' -> do - { ctxt' <- tcHsKindedContext ctxt + { stupid_theta <- tcStupidTheta ctxt cons ; want_generic <- doptM Opt_Generics ; tycon <- fixM (\ tycon -> do - { data_cons <- mappM (addLocM (tcConDecl new_or_data tycon tvs' ctxt')) cons + { unbox_strict <- doptM Opt_UnboxStrictFields + ; data_cons <- mappM (addLocM (tcConDecl unbox_strict new_or_data tycon tvs')) cons ; let tc_rhs = case new_or_data of - DataType -> mkDataTyConRhs data_cons + DataType -> mkDataTyConRhs stupid_theta data_cons NewType -> ASSERT( isSingleton data_cons ) - mkNewTyConRhs (head data_cons) - ; buildAlgTyCon tc_name tvs' ctxt' - tc_rhs arg_vrcs is_rec + mkNewTyConRhs tycon (head data_cons) + ; buildAlgTyCon tc_name tvs' tc_rhs arg_vrcs is_rec (want_generic && canDoGenerics data_cons) }) ; return (ATyCon tycon) @@ -405,37 +409,72 @@ tcTyClDecl1 calc_vrcs calc_isrec = returnM (ATyCon (mkForeignTyCon tc_name tc_ext_name liftedTypeKind 0 [])) ----------------------------------- -tcConDecl :: NewOrData -> TyCon -> [TyVar] -> ThetaType +tcConDecl :: Bool -- True <=> -funbox-strict_fields + -> NewOrData -> TyCon -> [TyVar] -> ConDecl Name -> TcM DataCon -tcConDecl new_or_data tycon tyvars ctxt - (ConDecl name ex_tvs ex_ctxt details) +tcConDecl unbox_strict new_or_data tycon tc_tvs + (ConDecl name ex_tvs ex_ctxt details) = tcTyVarBndrs ex_tvs $ \ ex_tvs' -> do { ex_ctxt' <- tcHsKindedContext ex_ctxt - ; unbox_strict <- doptM Opt_UnboxStrictFields ; let + is_vanilla = null ex_tvs && null (unLoc ex_ctxt) + -- Vanilla iff no ex_tvs and no context + tc_datacon is_infix field_lbls btys - = do { let { ubtys = map unLoc btys } - ; arg_tys <- mappM (tcHsKindedType . getBangType) ubtys - ; buildDataCon (unLoc name) is_infix - (argStrictness unbox_strict tycon ubtys arg_tys) + = do { let { bangs = map getBangStrictness btys } + ; arg_tys <- mappM tcHsBangType btys + ; buildDataCon (unLoc name) is_infix is_vanilla + (argStrictness unbox_strict tycon bangs arg_tys) (map unLoc field_lbls) - tyvars ctxt ex_tvs' ex_ctxt' - arg_tys tycon } + (tc_tvs ++ ex_tvs') + ex_ctxt' + arg_tys + tycon (mkTyVarTys tc_tvs) } ; case details of PrefixCon btys -> tc_datacon False [] btys InfixCon bty1 bty2 -> tc_datacon True [] [bty1,bty2] - RecCon fields -> do { checkTc (null ex_tvs') (exRecConErr name) + RecCon fields -> do { checkTc is_vanilla (exRecConErr name) ; let { (field_names, btys) = unzip fields } ; tc_datacon False field_names btys } } +tcConDecl unbox_strict new_or_data tycon tc_tvs + decl@(GadtDecl name con_ty) + = do { traceTc (text "tcConDecl" <+> ppr name) + ; (tvs, theta, bangs, arg_tys, tc, res_tys) <- tcLHsConSig con_ty + + ; traceTc (text "tcConDecl1" <+> ppr name) + ; let -- Now dis-assemble the type, and check its form + is_vanilla = null theta && mkTyVarTys tvs `tcEqTypes` res_tys + + -- Vanilla datacons guarantee to use the same + -- type variables as the parent tycon + (tvs', arg_tys', res_tys') + | is_vanilla = (tc_tvs, substTys subst arg_tys, substTys subst res_tys) + | otherwise = (tvs, arg_tys, res_tys) + subst = zipTopTvSubst tvs (mkTyVarTys tc_tvs) + + ; traceTc (text "tcConDecl3" <+> ppr name) + ; buildDataCon (unLoc name) False {- Not infix -} is_vanilla + (argStrictness unbox_strict tycon bangs arg_tys) + [{- No field labels -}] + tvs' theta arg_tys' tycon res_tys' } + +tcStupidTheta :: LHsContext Name -> [LConDecl Name] -> TcM (Maybe ThetaType) +-- For GADTs we don't allow a context on the data declaration +-- whereas for standard Haskell style data declarations, we do +tcStupidTheta ctxt (L _ (ConDecl _ _ _ _) : _) + = do { theta <- tcHsKindedContext ctxt; return (Just theta) } +tcStupidTheta ctxt other -- Includes an empty constructor list + = ASSERT( null (unLoc ctxt) ) return Nothing + +------------------- argStrictness :: Bool -- True <=> -funbox-strict_fields - -> TyCon -> [BangType Name] + -> TyCon -> [HsBang] -> [TcType] -> [StrictnessMark] -argStrictness unbox_strict tycon btys arg_tys - = zipWith (chooseBoxingStrategy unbox_strict tycon) - arg_tys - (map getBangStrictness btys ++ repeat HsNoBang) +argStrictness unbox_strict tycon bangs arg_tys + = ASSERT( length bangs == length arg_tys ) + zipWith (chooseBoxingStrategy unbox_strict tycon) arg_tys bangs -- We attempt to unbox/unpack a strict field when either: -- (i) The field is marked '!!', or @@ -496,10 +535,10 @@ checkValidTyCon tc = checkValidType syn_ctxt syn_rhs | otherwise = -- Check the context on the data decl - checkValidTheta (DataTyCtxt name) (tyConTheta tc) `thenM_` + checkValidTheta (DataTyCtxt name) (tyConStupidTheta tc) `thenM_` -- Check arg types of data constructors - mappM_ checkValidDataCon data_cons `thenM_` + mappM_ (checkValidDataCon tc) data_cons `thenM_` -- Check that fields with the same name share a type mappM_ check_fields groups @@ -510,33 +549,36 @@ checkValidTyCon tc (_, syn_rhs) = getSynTyConDefn tc data_cons = tyConDataCons tc - fields = [field | con <- data_cons, field <- dataConFieldLabels con] - groups = equivClasses cmp_name fields - cmp_name field1 field2 = fieldLabelName field1 `compare` fieldLabelName field2 + groups = equivClasses cmp_fld (concatMap get_fields data_cons) + cmp_fld (f1,_) (f2,_) = f1 `compare` f2 + get_fields con = dataConFieldLabels con `zip` dataConOrigArgTys con + -- dataConFieldLabels may return the empty list, which is fine - check_fields fields@(first_field_label : other_fields) + check_fields fields@((first_field_label, field_ty) : other_fields) -- These fields all have the same name, but are from -- different constructors in the data type = -- Check that all the fields in the group have the same type -- NB: this check assumes that all the constructors of a given -- data type use the same type variables - checkTc (all (tcEqType field_ty) other_tys) (fieldTypeMisMatch field_name) - where - field_ty = fieldLabelType first_field_label - field_name = fieldLabelName first_field_label - other_tys = map fieldLabelType other_fields + checkTc (all (tcEqType field_ty . snd) other_fields) + (fieldTypeMisMatch first_field_label) ------------------------------- -checkValidDataCon :: DataCon -> TcM () -checkValidDataCon con - = addErrCtxt (dataConCtxt con) ( - checkValidType ctxt (idType (dataConWrapId con)) `thenM_` +checkValidDataCon :: TyCon -> DataCon -> TcM () +checkValidDataCon tc con + = addErrCtxt (dataConCtxt con) $ + do { checkTc (dataConTyCon con == tc) (badDataConTyCon con) + ; checkValidType ctxt (idType (dataConWrapId con)) } + -- This checks the argument types and -- ambiguity of the existential context (if any) - checkFreeness ex_tvs ex_theta) + -- + -- Note [Sept 04] Now that tvs is all the tvs, this + -- test doesn't actually check anything +-- ; checkFreeness tvs ex_theta } where ctxt = ConArgCtxt (dataConName con) - (_, _, ex_tvs, ex_theta, _, _) = dataConSig con + (tvs, ex_theta, _, _, _) = dataConSig con ------------------------------- @@ -597,7 +639,7 @@ fieldTypeMisMatch field_name dataConCtxt con = sep [ptext SLIT("When checking the data constructor:"), nest 2 (ex_part <+> pprThetaArrow ex_theta <+> ppr con <+> arg_part)] where - (_, _, ex_tvs, ex_theta, arg_tys, _) = dataConSig con + (ex_tvs, ex_theta, arg_tys, _, _) = dataConSig con ex_part | null ex_tvs = empty | otherwise = ptext SLIT("forall") <+> hsep (map ppr ex_tvs) <> dot -- The 'ex_theta' part could be non-empty, if the user (bogusly) wrote @@ -635,21 +677,25 @@ badGenericMethodType op op_ty ptext SLIT("You can only use type variables, arrows, and tuples")]) recSynErr syn_decls - = addSrcSpan (getLoc (head syn_decls)) $ + = setSrcSpan (getLoc (head syn_decls)) $ addErr (sep [ptext SLIT("Cycle in type synonym declarations:"), nest 2 (vcat (map ppr_decl syn_decls))]) where ppr_decl (L loc decl) = ppr loc <> colon <+> ppr decl recClsErr cls_decls - = addSrcSpan (getLoc (head cls_decls)) $ + = setSrcSpan (getLoc (head cls_decls)) $ addErr (sep [ptext SLIT("Cycle in class declarations (via superclasses):"), nest 2 (vcat (map ppr_decl cls_decls))]) where ppr_decl (L loc decl) = ppr loc <> colon <+> ppr (decl { tcdSigs = [] }) exRecConErr name - = ptext SLIT("Can't combine named fields with locally-quantified type variables") + = ptext SLIT("Can't combine named fields with locally-quantified type variables or context") $$ (ptext SLIT("In the declaration of data constructor") <+> ppr name) + +badDataConTyCon data_con + = hang (ptext SLIT("Data constructor does not return its parent type:")) + 2 (ppr data_con) \end{code} diff --git a/ghc/compiler/typecheck/TcTyDecls.lhs b/ghc/compiler/typecheck/TcTyDecls.lhs index 1501d56f7e..a0d019a48a 100644 --- a/ghc/compiler/typecheck/TcTyDecls.lhs +++ b/ghc/compiler/typecheck/TcTyDecls.lhs @@ -28,7 +28,7 @@ import TyCon ( TyCon, ArgVrcs, tyConArity, tyConDataCons, tyConTyVars getSynTyConDefn, isSynTyCon, isAlgTyCon, isHiBootTyCon, tyConName, isNewTyCon, isProductTyCon, tyConArgVrcs, newTyConRhs ) import Class ( classTyCon ) -import DataCon ( dataConRepArgTys, dataConOrigArgTys ) +import DataCon ( dataConOrigArgTys ) import Var ( TyVar ) import VarSet import Name ( Name, isTyVarName ) @@ -362,7 +362,7 @@ calcTyConArgVrcs tyclss where data_cons = tyConDataCons tc vs = tyConTyVars tc - argtys = concatMap dataConRepArgTys data_cons -- Rep? or Orig? + argtys = concatMap dataConOrigArgTys data_cons -- Rep? or Orig? tcaoIter oi tc | isSynTyCon tc = let (tyvs,ty) = getSynTyConDefn tc diff --git a/ghc/compiler/typecheck/TcType.hi-boot-6 b/ghc/compiler/typecheck/TcType.hi-boot-6 index da1140e671..ee7d1789a2 100644 --- a/ghc/compiler/typecheck/TcType.hi-boot-6 +++ b/ghc/compiler/typecheck/TcType.hi-boot-6 @@ -1,3 +1,3 @@ module TcType where -data TyVarDetails +data TcTyVarDetails diff --git a/ghc/compiler/typecheck/TcType.lhs b/ghc/compiler/typecheck/TcType.lhs index eaade6d8ff..e1bfedbf1a 100644 --- a/ghc/compiler/typecheck/TcType.lhs +++ b/ghc/compiler/typecheck/TcType.lhs @@ -1,4 +1,4 @@ -% + % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % \section[TcType]{Types used in the typechecker} @@ -21,9 +21,11 @@ module TcType ( TcTyVar, TcTyVarSet, TcKind, -------------------------------- - -- TyVarDetails - TyVarDetails(..), isUserTyVar, isSkolemTyVar, isExistentialTyVar, - tyVarBindingInfo, + -- MetaDetails + TcTyVarDetails(..), + MetaDetails(Flexi, Indirect), SkolemInfo(..), pprSkolemTyVar, + isImmutableTyVar, isSkolemTyVar, isMetaTyVar, skolemTvInfo, metaTvRef, + isFlexi, isIndirect, -------------------------------- -- Builders @@ -46,7 +48,6 @@ module TcType ( isDoubleTy, isFloatTy, isIntTy, isIntegerTy, isAddrTy, isBoolTy, isUnitTy, isTauTy, tcIsTyVarTy, tcIsForAllTy, - allDistinctTyVars, --------------------------------- -- Misc type manipulators @@ -77,11 +78,6 @@ module TcType ( toDNType, -- :: Type -> DNType - --------------------------------- - -- Unifier and matcher - unifyTysX, unifyTyListsX, unifyExtendTyListsX, - matchTy, matchTys, match, - -------------------------------- -- Rexported from Type Kind, -- Stuff to do with kinds is insensitive to pre/post Tc @@ -95,6 +91,14 @@ module TcType ( mkTyConApp, mkGenTyConApp, mkAppTy, mkAppTys, mkSynTy, applyTy, applyTys, mkTyVarTy, mkTyVarTys, mkTyConTy, mkPredTy, mkPredTys, + -- Type substitutions + TvSubst(..), -- Representation visible to a few friends + TvSubstEnv, emptyTvSubst, + mkTvSubst, zipTvSubst, zipTopTvSubst, mkTopTvSubst, + getTvSubstEnv, setTvSubstEnv, getTvInScope, extendTvInScope, + extendTvSubst, extendTvSubstList, isInScope, + substTy, substTys, substTyWith, substTheta, substTyVar, + isUnLiftedType, -- Source types are always lifted isUnboxedTupleType, -- Ditto isPrimitiveType, @@ -137,14 +141,22 @@ import Type ( -- Re-exports tidyTyVarBndr, tidyOpenTyVar, tidyOpenTyVars, isSubKind, + TvSubst(..), + TvSubstEnv, emptyTvSubst, + mkTvSubst, zipTvSubst, zipTopTvSubst, mkTopTvSubst, + getTvSubstEnv, setTvSubstEnv, getTvInScope, extendTvInScope, + extendTvSubst, extendTvSubstList, isInScope, + substTy, substTys, substTyWith, substTheta, substTyVar, + typeKind, repType, pprKind, pprParendKind, pprType, pprParendType, pprPred, pprTheta, pprThetaArrow, pprClassPred ) import TyCon ( TyCon, isUnLiftedTyCon, tyConUnique ) +import DataCon ( DataCon ) import Class ( Class ) -import Var ( TyVar, tyVarKind, tcTyVarDetails ) +import Var ( TyVar, Id, isTcTyVar, tcTyVarDetails ) import ForeignCall ( Safety, playSafe, DNType(..) ) import VarEnv import VarSet @@ -158,10 +170,11 @@ import PrelNames -- Lots (e.g. in isFFIArgumentTy) import TysWiredIn ( unitTyCon, charTyCon, listTyCon ) import BasicTypes ( IPName(..), ipNameName ) import Unique ( Unique, Uniquable(..) ) -import SrcLoc ( SrcLoc ) -import Util ( cmpList, thenCmp, equalLength, snocView ) +import SrcLoc ( SrcLoc, SrcSpan ) +import Util ( cmpList, thenCmp, snocView ) import Maybes ( maybeToBool, expectJust ) import Outputable +import DATA_IOREF \end{code} @@ -212,8 +225,8 @@ type TcThetaType = ThetaType type TcSigmaType = TcType type TcRhoType = TcType type TcTauType = TcType - type TcKind = Kind +type TcTyVarSet = TyVarSet \end{code} @@ -231,67 +244,89 @@ why Var.lhs shouldn't actually have the definition, but it "belongs" here. \begin{code} type TcTyVar = TyVar -- Used only during type inference -data TyVarDetails - = SigTv -- Introduced when instantiating a type signature, - -- prior to checking that the defn of a fn does - -- have the expected type. Should not be instantiated. - -- f :: forall a. a -> a - -- f = e - -- When checking e, with expected type (a->a), we - -- should not instantiate a - - | ClsTv -- Scoped type variable introduced by a class decl - -- class C a where ... - - | InstTv -- Ditto, but instance decl - - | PatSigTv -- Scoped type variable, introduced by a pattern - -- type signature \ x::a -> e - - | ExistTv -- An existential type variable bound by a pattern for - -- a data constructor with an existential type. E.g. - -- data T = forall a. Eq a => MkT a - -- f (MkT x) = ... - -- The pattern MkT x will allocate an existential type - -- variable for 'a'. We distinguish these from all others - -- on one place, namely InstEnv.lookupInstEnv. - - | VanillaTv -- Everything else - -isUserTyVar :: TcTyVar -> Bool -- Avoid unifying these if possible -isUserTyVar tv = case tcTyVarDetails tv of - VanillaTv -> False - other -> True - -isSkolemTyVar :: TcTyVar -> Bool -isSkolemTyVar tv = case tcTyVarDetails tv of - SigTv -> True - ClsTv -> True - InstTv -> True - ExistTv -> True - other -> False - -isExistentialTyVar :: TcTyVar -> Bool -isExistentialTyVar tv = case tcTyVarDetails tv of - ExistTv -> True - other -> False - -tyVarBindingInfo :: TcTyVar -> SDoc -- Used in checkSigTyVars -tyVarBindingInfo tv - = sep [ptext SLIT("is bound by the") <+> details (tcTyVarDetails tv), - ptext SLIT("at") <+> ppr (getSrcLoc tv)] - where - details SigTv = ptext SLIT("type signature") - details ClsTv = ptext SLIT("class declaration") - details InstTv = ptext SLIT("instance declaration") - details PatSigTv = ptext SLIT("pattern type signature") - details ExistTv = ptext SLIT("existential constructor") - details VanillaTv = ptext SLIT("//vanilla//") -- Ditto +-- A TyVarDetails is inside a TyVar +data TcTyVarDetails + = SkolemTv SkolemInfo -- A skolem constant + | MetaTv (IORef MetaDetails) -- A meta type variable stands for a tau-type + +data SkolemInfo + = SigSkol Name -- Bound at a type signature + | ClsSkol Class -- Bound at a class decl + | InstSkol Id -- Bound at an instance decl + | PatSkol DataCon -- An existential type variable bound by a pattern for + SrcSpan -- a data constructor with an existential type. E.g. + -- data T = forall a. Eq a => MkT a + -- f (MkT x) = ... + -- The pattern MkT x will allocate an existential type + -- variable for 'a'. + | ArrowSkol SrcSpan -- An arrow form (see TcArrows) + + | GenSkol TcType -- Bound when doing a subsumption check for this type + SrcSpan + +data MetaDetails + = Flexi -- Flexi type variables unify to become + -- Indirects. + + | Indirect TcType -- Type indirections, treated as wobbly + -- for the purpose of GADT unification. + +pprSkolemTyVar :: TcTyVar -> SDoc +pprSkolemTyVar tv + = ASSERT( isSkolemTyVar tv ) + quotes (ppr tv) <+> ptext SLIT("is bound by") <+> ppr (skolemTvInfo tv) + +instance Outputable SkolemInfo where + ppr (SigSkol id) = ptext SLIT("the type signature for") <+> quotes (ppr id) + ppr (ClsSkol cls) = ptext SLIT("the class declaration for") <+> quotes (ppr cls) + ppr (InstSkol df) = ptext SLIT("the instance declaration at") <+> ppr (getSrcLoc df) + ppr (ArrowSkol loc) = ptext SLIT("the arrow form at") <+> ppr loc + ppr (PatSkol dc loc) = sep [ptext SLIT("the pattern for") <+> quotes (ppr dc), + nest 2 (ptext SLIT("at") <+> ppr loc)] + ppr (GenSkol ty loc) = sep [ptext SLIT("the polymorphic type") <+> quotes (ppr ty), + nest 2 (ptext SLIT("at") <+> ppr loc)] + +instance Outputable MetaDetails where + ppr Flexi = ptext SLIT("Flexi") + ppr (Indirect ty) = ptext SLIT("Indirect") <+> ppr ty + +isImmutableTyVar, isSkolemTyVar, isMetaTyVar :: TyVar -> Bool +isImmutableTyVar tv + | isTcTyVar tv = isSkolemTyVar tv + | otherwise = True + +isSkolemTyVar tv + = ASSERT( isTcTyVar tv ) + case tcTyVarDetails tv of + SkolemTv _ -> True + MetaTv _ -> False + +isMetaTyVar tv + = ASSERT( isTcTyVar tv ) + case tcTyVarDetails tv of + SkolemTv _ -> False + MetaTv _ -> True + +skolemTvInfo :: TyVar -> SkolemInfo +skolemTvInfo tv + = ASSERT( isTcTyVar tv ) + case tcTyVarDetails tv of + SkolemTv info -> info + +metaTvRef :: TyVar -> IORef MetaDetails +metaTvRef tv + = ASSERT( isTcTyVar tv ) + case tcTyVarDetails tv of + MetaTv ref -> ref + +isFlexi, isIndirect :: MetaDetails -> Bool +isFlexi Flexi = True +isFlexi other = False + +isIndirect (Indirect _) = True +isIndirect other = False \end{code} -\begin{code} -type TcTyVarSet = TyVarSet -\end{code} %************************************************************************ %* * @@ -472,30 +507,6 @@ tcSplitDFunTy ty (tvs, theta, clas, tys) }} \end{code} -(allDistinctTyVars tys tvs) = True - iff -all the types tys are type variables, -distinct from each other and from tvs. - -This is useful when checking that unification hasn't unified signature -type variables. For example, if the type sig is - f :: forall a b. a -> b -> b -we want to check that 'a' and 'b' havn't - (a) been unified with a non-tyvar type - (b) been unified with each other (all distinct) - (c) been unified with a variable free in the environment - -\begin{code} -allDistinctTyVars :: [Type] -> TyVarSet -> Bool - -allDistinctTyVars [] acc - = True -allDistinctTyVars (ty:tys) acc - = case tcGetTyVar_maybe ty of - Nothing -> False -- (a) - Just tv | tv `elemVarSet` acc -> False -- (b) or (c) - | otherwise -> allDistinctTyVars tys (acc `extendVarSet` tv) -\end{code} %************************************************************************ @@ -959,251 +970,3 @@ isByteArrayLikeTyCon tc = \end{code} -%************************************************************************ -%* * -\subsection{Unification with an explicit substitution} -%* * -%************************************************************************ - -Unify types with an explicit substitution and no monad. - -\begin{code} -type MySubst - = (TyVarSet, -- Set of template tyvars - TyVarSubstEnv) -- Not necessarily idempotent - -unifyTysX :: TyVarSet -- Template tyvars - -> Type - -> Type - -> Maybe TyVarSubstEnv -unifyTysX tmpl_tyvars ty1 ty2 - = uTysX ty1 ty2 (\(_,s) -> Just s) (tmpl_tyvars, emptySubstEnv) - -unifyExtendTyListsX - :: TyVarSet -- Template tyvars - -> TyVarSubstEnv -- Substitution to start with - -> [Type] - -> [Type] - -> Maybe TyVarSubstEnv -- Extended substitution -unifyExtendTyListsX tmpl_tyvars subst tys1 tys2 - = uTyListsX tys1 tys2 (\(_,s) -> Just s) (tmpl_tyvars, subst) - -unifyTyListsX :: TyVarSet -> [Type] -> [Type] - -> Maybe TyVarSubstEnv -unifyTyListsX tmpl_tyvars tys1 tys2 - = uTyListsX tys1 tys2 (\(_,s) -> Just s) (tmpl_tyvars, emptySubstEnv) - - -uTysX :: Type - -> Type - -> (MySubst -> Maybe result) - -> MySubst - -> Maybe result - -uTysX (NoteTy _ ty1) ty2 k subst = uTysX ty1 ty2 k subst -uTysX ty1 (NoteTy _ ty2) k subst = uTysX ty1 ty2 k subst - - -- Variables; go for uVar -uTysX (TyVarTy tyvar1) (TyVarTy tyvar2) k subst - | tyvar1 == tyvar2 - = k subst -uTysX (TyVarTy tyvar1) ty2 k subst@(tmpls,_) - | tyvar1 `elemVarSet` tmpls - = uVarX tyvar1 ty2 k subst -uTysX ty1 (TyVarTy tyvar2) k subst@(tmpls,_) - | tyvar2 `elemVarSet` tmpls - = uVarX tyvar2 ty1 k subst - - -- Predicates -uTysX (PredTy (IParam n1 t1)) (PredTy (IParam n2 t2)) k subst - | n1 == n2 = uTysX t1 t2 k subst -uTysX (PredTy (ClassP c1 tys1)) (PredTy (ClassP c2 tys2)) k subst - | c1 == c2 = uTyListsX tys1 tys2 k subst - - -- Functions; just check the two parts -uTysX (FunTy fun1 arg1) (FunTy fun2 arg2) k subst - = uTysX fun1 fun2 (uTysX arg1 arg2 k) subst - - -- Type constructors must match -uTysX (NewTcApp tc1 tys1) (NewTcApp tc2 tys2) k subst - | tc1 == tc2 = uTyListsX tys1 tys2 k subst -uTysX (TyConApp con1 tys1) (TyConApp con2 tys2) k subst - | (con1 == con2 && equalLength tys1 tys2) - = uTyListsX tys1 tys2 k subst - - -- Applications need a bit of care! - -- They can match FunTy and TyConApp, so use splitAppTy_maybe - -- NB: we've already dealt with type variables and Notes, - -- so if one type is an App the other one jolly well better be too -uTysX (AppTy s1 t1) ty2 k subst - = case tcSplitAppTy_maybe ty2 of - Just (s2, t2) -> uTysX s1 s2 (uTysX t1 t2 k) subst - Nothing -> Nothing -- Fail - -uTysX ty1 (AppTy s2 t2) k subst - = case tcSplitAppTy_maybe ty1 of - Just (s1, t1) -> uTysX s1 s2 (uTysX t1 t2 k) subst - Nothing -> Nothing -- Fail - - -- Not expecting for-alls in unification -#ifdef DEBUG -uTysX (ForAllTy _ _) ty2 k subst = panic "Unify.uTysX subst:ForAllTy (1st arg)" -uTysX ty1 (ForAllTy _ _) k subst = panic "Unify.uTysX subst:ForAllTy (2nd arg)" -#endif - - -- Anything else fails -uTysX ty1 ty2 k subst = Nothing - - -uTyListsX [] [] k subst = k subst -uTyListsX (ty1:tys1) (ty2:tys2) k subst = uTysX ty1 ty2 (uTyListsX tys1 tys2 k) subst -uTyListsX tys1 tys2 k subst = Nothing -- Fail if the lists are different lengths -\end{code} - -\begin{code} --- Invariant: tv1 is a unifiable variable -uVarX tv1 ty2 k subst@(tmpls, env) - = case lookupSubstEnv env tv1 of - Just (DoneTy ty1) -> -- Already bound - uTysX ty1 ty2 k subst - - Nothing -- Not already bound - | typeKind ty2 == tyVarKind tv1 - && occur_check_ok ty2 - -> -- No kind mismatch nor occur check - k (tmpls, extendSubstEnv env tv1 (DoneTy ty2)) - - | otherwise -> Nothing -- Fail if kind mis-match or occur check - where - occur_check_ok ty = all occur_check_ok_tv (varSetElems (tyVarsOfType ty)) - occur_check_ok_tv tv | tv1 == tv = False - | otherwise = case lookupSubstEnv env tv of - Nothing -> True - Just (DoneTy ty) -> occur_check_ok ty -\end{code} - - - -%************************************************************************ -%* * -\subsection{Matching on types} -%* * -%************************************************************************ - -Matching is a {\em unidirectional} process, matching a type against a -template (which is just a type with type variables in it). The -matcher assumes that there are no repeated type variables in the -template, so that it simply returns a mapping of type variables to -types. It also fails on nested foralls. - -@matchTys@ matches corresponding elements of a list of templates and -types. It and @matchTy@ both ignore usage annotations, unlike the -main function @match@. - -\begin{code} -matchTy :: TyVarSet -- Template tyvars - -> Type -- Template - -> Type -- Proposed instance of template - -> Maybe TyVarSubstEnv -- Matching substitution - - -matchTys :: TyVarSet -- Template tyvars - -> [Type] -- Templates - -> [Type] -- Proposed instance of template - -> Maybe (TyVarSubstEnv, -- Matching substitution - [Type]) -- Left over instance types - -matchTy tmpls ty1 ty2 = match ty1 ty2 tmpls (\ senv -> Just senv) emptySubstEnv - -matchTys tmpls tys1 tys2 = match_list tys1 tys2 tmpls - (\ (senv,tys) -> Just (senv,tys)) - emptySubstEnv -\end{code} - -@match@ is the main function. It takes a flag indicating whether -usage annotations are to be respected. - -\begin{code} -match :: Type -> Type -- Current match pair - -> TyVarSet -- Template vars - -> (TyVarSubstEnv -> Maybe result) -- Continuation - -> TyVarSubstEnv -- Current subst - -> Maybe result - --- When matching against a type variable, see if the variable --- has already been bound. If so, check that what it's bound to --- is the same as ty; if not, bind it and carry on. - -match (TyVarTy v) ty tmpls k senv - | v `elemVarSet` tmpls - = -- v is a template variable - case lookupSubstEnv senv v of - Nothing | typeKind ty `isSubKind` tyVarKind v - -- We do a kind check, just as in the uVarX above - -- The kind check is needed to avoid bogus matches - -- of (a b) with (c d), where the kinds don't match - -- An occur check isn't needed when matching. - -> k (extendSubstEnv senv v (DoneTy ty)) - - | otherwise -> Nothing -- Fails - - Just (DoneTy ty') | ty' `tcEqType` ty -> k senv -- Succeeds - | otherwise -> Nothing -- Fails - - | otherwise - = -- v is not a template variable; ty had better match - -- Can't use (==) because types differ - case tcGetTyVar_maybe ty of - Just v' | v == v' -> k senv -- Success - other -> Nothing -- Failure - -- This tcGetTyVar_maybe is *required* because it must strip Notes. - -- I guess the reason the Note-stripping case is *last* rather than first - -- is to preserve type synonyms etc., so I'm not moving it to the - -- top; but this means that (without the deNotetype) a type - -- variable may not match the pattern (TyVarTy v') as one would - -- expect, due to an intervening Note. KSW 2000-06. - - -- Predicates -match (PredTy (IParam n1 t1)) (PredTy (IParam n2 t2)) tmpls k senv - | n1 == n2 = match t1 t2 tmpls k senv -match (PredTy (ClassP c1 tys1)) (PredTy (ClassP c2 tys2)) tmpls k senv - | c1 == c2 = match_list_exactly tys1 tys2 tmpls k senv - - -- Functions; just check the two parts -match (FunTy arg1 res1) (FunTy arg2 res2) tmpls k senv - = match arg1 arg2 tmpls (match res1 res2 tmpls k) senv - - -- If the template is an application, try to make the - -- thing we are matching look like an application -match (AppTy fun1 arg1) ty2 tmpls k senv - = case tcSplitAppTy_maybe ty2 of - Just (fun2,arg2) -> match fun1 fun2 tmpls (match arg1 arg2 tmpls k) senv - Nothing -> Nothing -- Fail - - -- Newtypes are opaque; predicate types should not happen -match (NewTcApp tc1 tys1) (NewTcApp tc2 tys2) tmpls k senv - | tc1 == tc2 = match_list_exactly tys1 tys2 tmpls k senv -match (TyConApp tc1 tys1) (TyConApp tc2 tys2) tmpls k senv - | tc1 == tc2 = match_list_exactly tys1 tys2 tmpls k senv - - -- With type synonyms, we have to be careful for the exact - -- same reasons as in the unifier. Please see the - -- considerable commentary there before changing anything - -- here! (WDP 95/05) -match (NoteTy n1 ty1) ty2 tmpls k senv = match ty1 ty2 tmpls k senv -match ty1 (NoteTy n2 ty2) tmpls k senv = match ty1 ty2 tmpls k senv - --- Catch-all fails -match _ _ _ _ _ = Nothing - -match_list_exactly tys1 tys2 tmpls k senv - = match_list tys1 tys2 tmpls k' senv - where - k' (senv', tys2') | null tys2' = k senv' -- Succeed - | otherwise = Nothing -- Fail - -match_list [] tys2 tmpls k senv = k (senv, tys2) -match_list (ty1:tys1) [] tmpls k senv = Nothing -- Not enough arg tys => failure -match_list (ty1:tys1) (ty2:tys2) tmpls k senv - = match ty1 ty2 tmpls (match_list tys1 tys2 tmpls k) senv -\end{code} diff --git a/ghc/compiler/typecheck/TcUnify.lhs b/ghc/compiler/typecheck/TcUnify.lhs index c13cff66fa..3163802fff 100644 --- a/ghc/compiler/typecheck/TcUnify.lhs +++ b/ghc/compiler/typecheck/TcUnify.lhs @@ -6,66 +6,66 @@ \begin{code} module TcUnify ( -- Full-blown subsumption - tcSubOff, tcSubExp, tcGen, + tcSubPat, tcSubExp, tcGen, checkSigTyVars, checkSigTyVarsWrt, sigCtxt, findGlobals, -- Various unifications - unifyTauTy, unifyTauTyList, unifyTauTyLists, + unifyTauTy, unifyTauTyList, unifyKind, unifyKinds, unifyFunKind, checkExpectedKind, -------------------------------- -- Holes - Expected(..), newHole, readExpectedType, + Expected(..), tcInfer, readExpectedType, zapExpectedType, zapExpectedTo, zapExpectedBranches, - subFunTys, unifyFunTy, - zapToListTy, unifyListTy, - zapToPArrTy, unifyPArrTy, - zapToTupleTy, unifyTupleTy - + subFunTys, unifyFunTys, + zapToListTy, unifyListTy, + zapToTyConApp, unifyTyConApp, + unifyAppTy ) where #include "HsVersions.h" - -import HsSyn ( HsExpr(..) ) +-- gaw 2004 +import HsSyn ( HsExpr(..) , MatchGroup(..), hsLMatchPats ) import TcHsSyn ( mkHsLet, mkHsDictLam, ExprCoFn, idCoercion, isIdCoercion, mkCoercion, (<.>), (<$>) ) import TypeRep ( Type(..), PredType(..), TyNote(..) ) import TcRnMonad -- TcType, amongst others import TcType ( TcKind, TcType, TcSigmaType, TcRhoType, TcTyVar, TcTauType, - TcTyVarSet, TcThetaType, TyVarDetails(SigTv), - isTauTy, isSigmaTy, mkFunTys, mkTyConApp, + TcTyVarSet, TcThetaType, + SkolemInfo( GenSkol ), MetaDetails(..), + pprSkolemTyVar, isTauTy, isSigmaTy, mkFunTys, mkTyConApp, tcSplitAppTy_maybe, tcSplitTyConApp_maybe, - tcGetTyVar_maybe, tcGetTyVar, - mkFunTy, tyVarsOfType, mkPhiTy, - typeKind, tcSplitFunTy_maybe, mkForAllTys, - isSkolemTyVar, isUserTyVar, + tyVarsOfType, mkPhiTy, mkTyVarTy, + typeKind, tcSplitFunTy_maybe, mkForAllTys, mkAppTy, tidyOpenType, tidyOpenTypes, tidyOpenTyVar, tidyOpenTyVars, - allDistinctTyVars, pprType ) + pprType, isSkolemTyVar ) import Kind ( Kind(..), SimpleKind, KindVar, isArgTypeKind, - openTypeKind, liftedTypeKind, mkArrowKind, + openTypeKind, liftedTypeKind, mkArrowKind, kindFunResult, isOpenTypeKind, argTypeKind, isLiftedTypeKind, isUnliftedTypeKind, isSubKind, pprKind, splitKindFunTys ) import Inst ( newDicts, instToId, tcInstCall ) -import TcMType ( getTcTyVar, putTcTyVar, tcInstType, newKindVar, - newTyVarTy, newTyVarTys, zonkTcKind, - zonkTcType, zonkTcTyVars, zonkTcTyVarsAndFV, - readKindVar,writeKindVar ) +import TcMType ( condLookupTcTyVar, LookupTyVarResult(..), + putMetaTyVar, tcSkolType, newKindVar, tcInstTyVars, newMetaTyVar, + newTyFlexiVarTy, zonkTcKind, + zonkType, zonkTcType, zonkTcTyVars, zonkTcTyVarsAndFV, + readKindVar, writeKindVar ) import TcSimplify ( tcSimplifyCheck ) -import TysWiredIn ( listTyCon, parrTyCon, tupleTyCon ) import TcEnv ( tcGetGlobalTyVars, findGlobals ) -import TyCon ( TyCon, tyConArity, isTupleTyCon, tupleTyConBoxity ) +import TyCon ( TyCon, tyConArity, tyConTyVars ) +import TysWiredIn ( listTyCon ) import Id ( Id, mkSysLocal ) import Var ( Var, varName, tyVarKind ) -import VarSet ( emptyVarSet, unitVarSet, unionVarSet, elemVarSet, varSetElems ) +import VarSet ( emptyVarSet, unitVarSet, unionVarSet, elemVarSet, + varSetElems, intersectsVarSet, mkVarSet ) import VarEnv -import Name ( isSystemName ) +import Name ( isSystemName, mkSysTvName ) import ErrUtils ( Message ) import SrcLoc ( noLoc ) -import BasicTypes ( Boxity, Arity, isBoxed ) -import Util ( equalLength, lengthExceeds, notNull ) +import BasicTypes ( Arity ) +import Util ( equalLength, notNull ) import Outputable \end{code} @@ -83,9 +83,15 @@ Notes on holes data Expected ty = Infer (TcRef ty) -- The hole to fill in for type inference | Check ty -- The type to check during type checking -newHole :: TcM (TcRef ty) newHole = newMutVar (error "Empty hole in typechecker") +tcInfer :: (Expected ty -> TcM a) -> TcM (a,ty) +tcInfer tc_infer + = do { hole <- newHole + ; res <- tc_infer (Infer hole) + ; res_ty <- readMutVar hole + ; return (res, res_ty) } + readExpectedType :: Expected ty -> TcM ty readExpectedType (Infer hole) = readMutVar hole readExpectedType (Check ty) = returnM ty @@ -94,29 +100,38 @@ zapExpectedType :: Expected TcType -> Kind -> TcM TcTauType -- In the inference case, ensure we have a monotype -- (including an unboxed tuple) zapExpectedType (Infer hole) kind - = do { ty <- newTyVarTy kind ; + = do { ty <- newTyFlexiVarTy kind ; writeMutVar hole ty ; return ty } zapExpectedType (Check ty) kind | typeKind ty `isSubKind` kind = return ty - | otherwise = do { ty1 <- newTyVarTy kind + | otherwise = do { ty1 <- newTyFlexiVarTy kind ; unifyTauTy ty1 ty ; return ty } -- The unify is to ensure that 'ty' has the desired kind -- For example, in (case e of r -> b) we push an OpenTypeKind -- type variable +zapExpectedBranches :: MatchGroup id -> Expected TcRhoType -> TcM (Expected TcRhoType) +-- If there is more than one branch in a case expression, +-- and exp_ty is a 'hole', all branches must be types, not type schemes, +-- otherwise the order in which we check them would affect the result. +zapExpectedBranches (MatchGroup [match] _) exp_ty + = return exp_ty -- One branch +zapExpectedBranches matches (Check ty) + = return (Check ty) +zapExpectedBranches matches (Infer hole) + = do { -- Many branches, and inference mode, + -- so switch to checking mode with a monotype + ty <- newTyFlexiVarTy openTypeKind + ; writeMutVar hole ty + ; return (Check ty) } + zapExpectedTo :: Expected TcType -> TcTauType -> TcM () -zapExpectedTo (Infer hole) ty2 = writeMutVar hole ty2 zapExpectedTo (Check ty1) ty2 = unifyTauTy ty1 ty2 - -zapExpectedBranches :: [a] -> Expected TcType -> TcM (Expected TcType) --- Zap the expected type to a monotype if there is more than one branch -zapExpectedBranches branches exp_ty - | lengthExceeds branches 1 = zapExpectedType exp_ty openTypeKind `thenM` \ exp_ty' -> - return (Check exp_ty') - | otherwise = returnM exp_ty +zapExpectedTo (Infer hole) ty2 = do { ty2' <- zonkTcType ty2; writeMutVar hole ty2' } + -- See Note [Zonk return type] instance Outputable ty => Outputable (Expected ty) where ppr (Check ty) = ptext SLIT("Expected type") <+> ppr ty @@ -140,137 +155,185 @@ creation of type variables. type variables, so we should create new ordinary type variables \begin{code} -subFunTys :: [pat] - -> Expected TcRhoType -- Fail if ty isn't a function type - -> ([(pat, Expected TcRhoType)] -> Expected TcRhoType -> TcM a) - -> TcM a +subFunTys :: MatchGroup name + -> Expected TcRhoType -- Fail if ty isn't a function type + -> ([Expected TcRhoType] -> Expected TcRhoType -> TcM a) + -> TcM a -subFunTys pats (Infer hole) thing_inside +subFunTys (MatchGroup (match:null_matches) _) (Infer hole) thing_inside = -- This is the interesting case - mapM new_pat_hole pats `thenM` \ pats_w_holes -> - newHole `thenM` \ res_hole -> + ASSERT( null null_matches ) + do { pat_holes <- mapM (\ _ -> newHole) (hsLMatchPats match) + ; res_hole <- newHole - -- Do the business - thing_inside pats_w_holes (Infer res_hole) `thenM` \ answer -> + -- Do the business + ; res <- thing_inside (map Infer pat_holes) (Infer res_hole) - -- Extract the answers - mapM read_pat_hole pats_w_holes `thenM` \ arg_tys -> - readMutVar res_hole `thenM` \ res_ty -> + -- Extract the answers + ; arg_tys <- mapM readMutVar pat_holes + ; res_ty <- readMutVar res_hole - -- Write the answer into the incoming hole - writeMutVar hole (mkFunTys arg_tys res_ty) `thenM_` + -- Write the answer into the incoming hole + ; writeMutVar hole (mkFunTys arg_tys res_ty) - -- And return the answer - returnM answer - where - new_pat_hole pat = newHole `thenM` \ hole -> return (pat, Infer hole) - read_pat_hole (pat, Infer hole) = readMutVar hole + -- And return the answer + ; return res } -subFunTys pats (Check ty) thing_inside - = go pats ty `thenM` \ (pats_w_tys, res_ty) -> - thing_inside pats_w_tys res_ty - where - go [] ty = return ([], Check ty) - go (pat:pats) ty = unifyFunTy ty `thenM` \ (arg,res) -> - go pats res `thenM` \ (pats_w_tys, final_res) -> - return ((pat, Check arg) : pats_w_tys, final_res) - -unifyFunTy :: TcRhoType -- Fail if ty isn't a function type - -> TcM (TcType, TcType) -- otherwise return arg and result types - -unifyFunTy ty@(TyVarTy tyvar) - = getTcTyVar tyvar `thenM` \ maybe_ty -> - case maybe_ty of - Just ty' -> unifyFunTy ty' - Nothing -> unify_fun_ty_help ty - -unifyFunTy ty +subFunTys (MatchGroup (match:matches) _) (Check ty) thing_inside + = ASSERT( all ((== length (hsLMatchPats match)) . length . hsLMatchPats) matches ) + -- Assertion just checks that all the matches have the same number of pats + do { (pat_tys, res_ty) <- unifyFunTys (length (hsLMatchPats match)) ty + ; thing_inside (map Check pat_tys) (Check res_ty) } + +unifyFunTys :: Arity -> TcRhoType -> TcM ([TcSigmaType], TcRhoType) +-- Fail if ty isn't a function type, otherwise return arg and result types +-- The result types are guaranteed wobbly if the argument is wobbly +-- +-- Does not allocate unnecessary meta variables: if the input already is +-- a function, we just take it apart. Not only is this efficient, it's important +-- for (a) higher rank: the argument might be of form +-- (forall a. ty) -> other +-- If allocated (fresh-meta-var1 -> fresh-meta-var2) and unified, we'd +-- blow up with the meta var meets the forall +-- +-- (b) GADTs: if the argument is not wobbly we do not want the result to be + +unifyFunTys arity ty = unify_fun_ty True arity ty + +unify_fun_ty use_refinement arity ty + | arity == 0 + = do { res_ty <- wobblify use_refinement ty + ; return ([], ty) } + +unify_fun_ty use_refinement arity (NoteTy _ ty) + = unify_fun_ty use_refinement arity ty + +unify_fun_ty use_refinement arity ty@(TyVarTy tv) + = do { details <- condLookupTcTyVar use_refinement tv + ; case details of + IndirectTv use' ty' -> unify_fun_ty use' arity ty' + other -> unify_fun_help arity ty + } + +unify_fun_ty use_refinement arity ty = case tcSplitFunTy_maybe ty of - Just arg_and_res -> returnM arg_and_res - Nothing -> unify_fun_ty_help ty - -unify_fun_ty_help ty -- Special cases failed, so revert to ordinary unification - = newTyVarTy argTypeKind `thenM` \ arg -> - newTyVarTy openTypeKind `thenM` \ res -> - unifyTauTy ty (mkFunTy arg res) `thenM_` - returnM (arg,res) + Just (arg,res) -> do { arg' <- wobblify use_refinement arg + ; (args', res') <- unify_fun_ty use_refinement (arity-1) res + ; return (arg':args', res') } + + Nothing -> unify_fun_help arity ty + -- Usually an error, but ty could be (a Int Bool), which can match + +unify_fun_help :: Arity -> TcRhoType -> TcM ([TcSigmaType], TcRhoType) +unify_fun_help arity ty + = do { args <- mappM newTyFlexiVarTy (replicate arity argTypeKind) + ; res <- newTyFlexiVarTy openTypeKind + ; unifyTauTy ty (mkFunTys args res) + ; return (args, res) } \end{code} \begin{code} ---------------------- -zapToListTy, zapToPArrTy :: Expected TcType -- expected list type - -> TcM TcType -- list element type -unifyListTy, unifyPArrTy :: TcType -> TcM TcType -zapToListTy = zapToXTy listTyCon -unifyListTy = unifyXTy listTyCon -zapToPArrTy = zapToXTy parrTyCon -unifyPArrTy = unifyXTy parrTyCon +zapToTyConApp :: TyCon -- T :: k1 -> ... -> kn -> * + -> Expected TcSigmaType -- Expected type (T a b c) + -> TcM [TcType] -- Element types, a b c + -- Insists that the Expected type is not a forall-type + +zapToTyConApp tc (Check ty) + = unifyTyConApp tc ty -- NB: fails for a forall-type +zapToTyConApp tc (Infer hole) + = do { (tc_app, elt_tys) <- newTyConApp tc + ; writeMutVar hole tc_app + ; return elt_tys } + +zapToListTy :: Expected TcType -> TcM TcType -- Special case for lists +zapToListTy exp_ty = do { [elt_ty] <- zapToTyConApp listTyCon exp_ty + ; return elt_ty } ---------------------- -zapToXTy :: TyCon -- T :: *->* - -> Expected TcType -- Expected type (T a) - -> TcM TcType -- Element type, a +unifyTyConApp :: TyCon -> TcType -> TcM [TcType] +unifyTyConApp tc ty = unify_tc_app True tc ty + -- Add a boolean flag to remember whether to use + -- the type refinement or not + +unifyListTy :: TcType -> TcM TcType -- Special case for lists +unifyListTy exp_ty = do { [elt_ty] <- unifyTyConApp listTyCon exp_ty + ; return elt_ty } + +---------- +unify_tc_app use_refinement tc (NoteTy _ ty) + = unify_tc_app use_refinement tc ty + +unify_tc_app use_refinement tc ty@(TyVarTy tyvar) + = do { details <- condLookupTcTyVar use_refinement tyvar + ; case details of + IndirectTv use' ty' -> unify_tc_app use' tc ty' + other -> unify_tc_app_help tc ty + } + +unify_tc_app use_refinement tc ty + | Just (tycon, arg_tys) <- tcSplitTyConApp_maybe ty, + tycon == tc + = ASSERT( tyConArity tycon == length arg_tys ) -- ty::* + mapM (wobblify use_refinement) arg_tys + +unify_tc_app use_refinement tc ty = unify_tc_app_help tc ty + +---------- +unify_tc_app_help tc ty -- Revert to ordinary unification + = do { (tc_app, arg_tys) <- newTyConApp tc + ; if not (isTauTy ty) then -- Can happen if we call zapToTyConApp tc (forall a. ty) + unifyMisMatch ty tc_app + else do + { unifyTauTy ty tc_app + ; returnM arg_tys } } -zapToXTy tc (Check ty) = unifyXTy tc ty -zapToXTy tc (Infer hole) = do { elt_ty <- newTyVarTy liftedTypeKind ; - writeMutVar hole (mkTyConApp tc [elt_ty]) ; - return elt_ty } ---------------------- -unifyXTy :: TyCon -> TcType -> TcM TcType -unifyXTy tc ty@(TyVarTy tyvar) - = getTcTyVar tyvar `thenM` \ maybe_ty -> - case maybe_ty of - Just ty' -> unifyXTy tc ty' - other -> unify_x_ty_help tc ty - -unifyXTy tc ty - = case tcSplitTyConApp_maybe ty of - Just (tycon, [arg_ty]) | tycon == tc -> returnM arg_ty - other -> unify_x_ty_help tc ty - -unify_x_ty_help tc ty -- Revert to ordinary unification - = newTyVarTy liftedTypeKind `thenM` \ elt_ty -> - unifyTauTy ty (mkTyConApp tc [elt_ty]) `thenM_` - returnM elt_ty -\end{code} +unifyAppTy :: TcType -- Expected type function: m + -> TcType -- Type to split: m a + -> TcM TcType -- Type arg: a +unifyAppTy tc ty = unify_app_ty True tc ty + +unify_app_ty use tc (NoteTy _ ty) = unify_app_ty use tc ty + +unify_app_ty use tc ty@(TyVarTy tyvar) + = do { details <- condLookupTcTyVar use tyvar + ; case details of + IndirectTv use' ty' -> unify_app_ty use' tc ty' + other -> unify_app_ty_help tc ty + } + +unify_app_ty use tc ty + | Just (fun_ty, arg_ty) <- tcSplitAppTy_maybe ty + = do { unifyTauTy tc fun_ty + ; wobblify use arg_ty } + + | otherwise = unify_app_ty_help tc ty + +unify_app_ty_help tc ty -- Revert to ordinary unification + = do { arg_ty <- newTyFlexiVarTy (kindFunResult (typeKind tc)) + ; unifyTauTy (mkAppTy tc arg_ty) ty + ; return arg_ty } + -\begin{code} ---------------------- -zapToTupleTy :: Boxity -> Arity -> Expected TcType -> TcM [TcType] -zapToTupleTy boxity arity (Check ty) = unifyTupleTy boxity arity ty -zapToTupleTy boxity arity (Infer hole) = do { (tup_ty, arg_tys) <- new_tuple_ty boxity arity ; - writeMutVar hole tup_ty ; - return arg_tys } - -unifyTupleTy boxity arity ty@(TyVarTy tyvar) - = getTcTyVar tyvar `thenM` \ maybe_ty -> - case maybe_ty of - Just ty' -> unifyTupleTy boxity arity ty' - other -> unify_tuple_ty_help boxity arity ty - -unifyTupleTy boxity arity ty - = case tcSplitTyConApp_maybe ty of - Just (tycon, arg_tys) - | isTupleTyCon tycon - && tyConArity tycon == arity - && tupleTyConBoxity tycon == boxity - -> returnM arg_tys - other -> unify_tuple_ty_help boxity arity ty - -unify_tuple_ty_help boxity arity ty - = new_tuple_ty boxity arity `thenM` \ (tup_ty, arg_tys) -> - unifyTauTy ty tup_ty `thenM_` - returnM arg_tys - -new_tuple_ty boxity arity - = newTyVarTys arity kind `thenM` \ arg_tys -> - return (mkTyConApp tup_tc arg_tys, arg_tys) - where - tup_tc = tupleTyCon boxity arity - kind | isBoxed boxity = liftedTypeKind - | otherwise = argTypeKind -- Components of an unboxed tuple - -- can be unboxed, but not unboxed tuples +wobblify :: Bool -- True <=> don't wobblify + -> TcTauType + -> TcM TcTauType +-- Return a wobbly type. At the moment we do that by +-- allocating a fresh meta type variable. +wobblify True ty = return ty +wobblify False ty = do { uniq <- newUnique + ; tv <- newMetaTyVar (mkSysTvName uniq FSLIT("w")) + (typeKind ty) + (Indirect ty) + ; return (mkTyVarTy tv) } + +---------------------- +newTyConApp :: TyCon -> TcM (TcTauType, [TcTauType]) +newTyConApp tc = do { (tvs, args, _) <- tcInstTyVars (tyConTyVars tc) + ; return (mkTyConApp tc args, args) } \end{code} @@ -295,37 +358,61 @@ which takes an HsExpr of type offered_ty into one of type expected_ty. \begin{code} +----------------------- +-- tcSubExp is used for expressions tcSubExp :: Expected TcRhoType -> TcRhoType -> TcM ExprCoFn -tcSubOff :: TcSigmaType -> Expected TcSigmaType -> TcM ExprCoFn -\end{code} -These two check for holes +tcSubExp (Infer hole) offered_ty + = do { offered' <- zonkTcType offered_ty + -- Note [Zonk return type] + -- zonk to take advantage of the current GADT type refinement. + -- If we don't we get spurious "existential type variable escapes": + -- case (x::Maybe a) of + -- Just b (y::b) -> y + -- We need the refinement [b->a] to be applied to the result type + ; writeMutVar hole offered' + ; return idCoercion } -\begin{code} -tcSubExp expected_ty offered_ty - = traceTc (text "tcSubExp" <+> (ppr expected_ty $$ ppr offered_ty)) `thenM_` - checkHole expected_ty offered_ty tcSub +tcSubExp (Check expected_ty) offered_ty + = tcSub expected_ty offered_ty -tcSubOff expected_ty offered_ty - = checkHole offered_ty expected_ty (\ off exp -> tcSub exp off) +----------------------- +-- tcSubPat is used for patterns +tcSubPat :: TcSigmaType -- Pattern type signature + -> Expected TcSigmaType -- Type from context + -> TcM () +-- In patterns we insist on an exact match; hence no CoFn returned +-- See Note [Pattern coercions] in TcPat + +tcSubPat sig_ty (Infer hole) + = do { sig_ty' <- zonkTcType sig_ty + ; writeMutVar hole sig_ty' -- See notes with tcSubExp above + ; return () } + +tcSubPat sig_ty (Check exp_ty) + = do { co_fn <- tcSub sig_ty exp_ty + + ; if isIdCoercion co_fn then + return () + else + unifyMisMatch sig_ty exp_ty } +\end{code} --- checkHole looks for a hole in its first arg; --- If so, and it is uninstantiated, it fills in the hole --- with its second arg --- Otherwise it calls thing_inside, passing the two args, looking --- through any instantiated hole -checkHole (Infer hole) other_ty thing_inside - = do { writeMutVar hole other_ty; return idCoercion } -checkHole (Check ty) other_ty thing_inside - = thing_inside ty other_ty -\end{code} +%************************************************************************ +%* * + tcSub: main subsumption-check code +%* * +%************************************************************************ No holes expected now. Add some error-check context info. \begin{code} +----------------- tcSub :: TcSigmaType -> TcSigmaType -> TcM ExprCoFn -- Locally used only + -- tcSub exp act checks that + -- act <= exp tcSub expected_ty actual_ty = traceTc (text "tcSub" <+> details) `thenM_` addErrCtxtM (unifyCtxt "type" expected_ty actual_ty) @@ -333,11 +420,8 @@ tcSub expected_ty actual_ty where details = vcat [text "Expected:" <+> ppr expected_ty, text "Actual: " <+> ppr actual_ty] -\end{code} - -tc_sub carries the types before and after expanding type synonyms -\begin{code} +----------------- tc_sub :: TcSigmaType -- expected_ty, before expanding synonyms -> TcSigmaType -- ..and after -> TcSigmaType -- actual_ty, before @@ -377,7 +461,7 @@ tc_sub exp_sty expected_ty act_sty actual_ty tc_sub exp_sty expected_ty act_sty actual_ty | isSigmaTy actual_ty - = tcInstCall Rank2Origin actual_ty `thenM` \ (inst_fn, body_ty) -> + = tcInstCall InstSigOrigin actual_ty `thenM` \ (inst_fn, _, body_ty) -> tc_sub exp_sty expected_ty body_ty body_ty `thenM` \ co_fn -> returnM (co_fn <.> inst_fn) @@ -399,7 +483,7 @@ tc_sub _ (FunTy exp_arg exp_res) _ (FunTy act_arg act_res) -- when the arg/res is not a tau-type? -- NO! e.g. f :: ((forall a. a->a) -> Int) -> Int -- then x = (f,f) --- is perfectly fine, because we can instantiat f's type to a monotype +-- is perfectly fine, because we can instantiate f's type to a monotype -- -- However, we get can get jolly unhelpful error messages. -- e.g. foo = id runST @@ -413,34 +497,22 @@ tc_sub _ (FunTy exp_arg exp_res) _ (FunTy act_arg act_res) -- -- I'm not quite sure what to do about this! -tc_sub exp_sty exp_ty@(FunTy exp_arg exp_res) _ (TyVarTy tv) - = getTcTyVar tv `thenM` \ maybe_ty -> - case maybe_ty of - Just ty -> tc_sub exp_sty exp_ty ty ty - Nothing -> imitateFun tv exp_sty `thenM` \ (act_arg, act_res) -> - tcSub_fun exp_arg exp_res act_arg act_res +tc_sub exp_sty exp_ty@(FunTy exp_arg exp_res) _ act_ty + = do { ([act_arg], act_res) <- unifyFunTys 1 act_ty + ; tcSub_fun exp_arg exp_res act_arg act_res } -tc_sub _ (TyVarTy tv) act_sty act_ty@(FunTy act_arg act_res) - = getTcTyVar tv `thenM` \ maybe_ty -> - case maybe_ty of - Just ty -> tc_sub ty ty act_sty act_ty - Nothing -> imitateFun tv act_sty `thenM` \ (exp_arg, exp_res) -> - tcSub_fun exp_arg exp_res act_arg act_res +tc_sub _ exp_ty act_sty act_ty@(FunTy act_arg act_res) + = do { ([exp_arg], exp_res) <- unifyFunTys 1 exp_ty + ; tcSub_fun exp_arg exp_res act_arg act_res } ----------------------------------- -- Unification case -- If none of the above match, we revert to the plain unifier tc_sub exp_sty expected_ty act_sty actual_ty - = uTys exp_sty expected_ty act_sty actual_ty `thenM_` + = uTys True exp_sty expected_ty True act_sty actual_ty `thenM_` returnM idCoercion \end{code} -%************************************************************************ -%* * -\subsection{Functions} -%* * -%************************************************************************ - \begin{code} tcSub_fun exp_arg exp_res act_arg act_res = tc_sub act_arg act_arg exp_arg exp_arg `thenM` \ co_fn_arg -> @@ -464,21 +536,6 @@ tcSub_fun exp_arg exp_res act_arg act_res -- co_fn_res $it :: HsExpr exp_res in returnM coercion - -imitateFun :: TcTyVar -> TcType -> TcM (TcType, TcType) -imitateFun tv ty - = -- NB: tv is an *ordinary* tyvar and so are the new ones - - -- Check that tv isn't a type-signature type variable - -- (This would be found later in checkSigTyVars, but - -- we get a better error message if we do it here.) - checkM (not (isSkolemTyVar tv)) - (failWithTcM (unifyWithSigErr tv ty)) `thenM_` - - newTyVarTy argTypeKind `thenM` \ arg -> - newTyVarTy openTypeKind `thenM` \ res -> - putTcTyVar tv (mkFunTy arg res) `thenM_` - returnM (arg,res) \end{code} @@ -499,10 +556,12 @@ tcGen :: TcSigmaType -- expected_ty tcGen expected_ty extra_tvs thing_inside -- We expect expected_ty to be a forall-type -- If not, the call is a no-op - = tcInstType SigTv expected_ty `thenM` \ (forall_tvs, theta, phi_ty) -> + = do { span <- getSrcSpanM + ; let rigid_info = GenSkol expected_ty span + ; (forall_tvs, theta, phi_ty) <- tcSkolType rigid_info expected_ty -- Type-check the arg and unify with poly type - getLIE (thing_inside phi_ty) `thenM` \ (result, lie) -> + ; (result, lie) <- getLIE (thing_inside phi_ty) -- Check that the "forall_tvs" havn't been constrained -- The interesting bit here is that we must include the free variables @@ -515,30 +574,28 @@ tcGen expected_ty extra_tvs thing_inside -- We expect expected_ty to be a forall -- Conclusion: include the free vars of the expected_ty in the -- list of "free vars" for the signature check. - newDicts SignatureOrigin theta `thenM` \ dicts -> - tcSimplifyCheck sig_msg forall_tvs dicts lie `thenM` \ inst_binds -> + ; dicts <- newDicts (SigOrigin rigid_info) theta + ; inst_binds <- tcSimplifyCheck sig_msg forall_tvs dicts lie #ifdef DEBUG - zonkTcTyVars forall_tvs `thenM` \ forall_tys -> - traceTc (text "tcGen" <+> vcat [text "extra_tvs" <+> ppr extra_tvs, + ; forall_tys <- zonkTcTyVars forall_tvs + ; traceTc (text "tcGen" <+> vcat [text "extra_tvs" <+> ppr extra_tvs, text "expected_ty" <+> ppr expected_ty, text "inst ty" <+> ppr forall_tvs <+> ppr theta <+> ppr phi_ty, text "free_tvs" <+> ppr free_tvs, - text "forall_tys" <+> ppr forall_tys]) `thenM_` + text "forall_tys" <+> ppr forall_tys]) #endif - checkSigTyVarsWrt free_tvs forall_tvs `thenM` \ zonked_tvs -> - - traceTc (text "tcGen:done") `thenM_` + ; checkSigTyVarsWrt free_tvs forall_tvs + ; traceTc (text "tcGen:done") - let + ; let -- This HsLet binds any Insts which came out of the simplification. -- It's a bit out of place here, but using AbsBind involves inventing -- a couple of new names which seems worse. - dict_ids = map instToId dicts - co_fn e = TyLam zonked_tvs (mkHsDictLam dict_ids (mkHsLet inst_binds (noLoc e))) - in - returnM (mkCoercion co_fn, result) + dict_ids = map instToId dicts + co_fn e = TyLam forall_tvs (mkHsDictLam dict_ids (mkHsLet inst_binds (noLoc e))) + ; returnM (mkCoercion co_fn, result) } where free_tvs = tyVarsOfType expected_ty `unionVarSet` extra_tvs sig_msg = ptext SLIT("expected type of an expression") @@ -565,7 +622,7 @@ unifyTauTy ty1 ty2 -- ty1 expected, ty2 inferred ASSERT2( isTauTy ty1, ppr ty1 ) ASSERT2( isTauTy ty2, ppr ty2 ) addErrCtxtM (unifyCtxt "type" ty1 ty2) $ - uTys ty1 ty1 ty2 ty2 + uTys True ty1 ty1 True ty2 ty2 \end{code} @unifyTauTyList@ unifies corresponding elements of two lists of @@ -574,11 +631,17 @@ of equal length. We charge down the list explicitly so that we can complain if their lengths differ. \begin{code} -unifyTauTyLists :: [TcTauType] -> [TcTauType] -> TcM () -unifyTauTyLists [] [] = returnM () -unifyTauTyLists (ty1:tys1) (ty2:tys2) = uTys ty1 ty1 ty2 ty2 `thenM_` - unifyTauTyLists tys1 tys2 -unifyTauTyLists ty1s ty2s = panic "Unify.unifyTauTyLists: mismatched type lists!" +unifyTauTyLists :: Bool -> -- Allow refinements on tys1 + [TcTauType] -> + Bool -> -- Allow refinements on tys2 + [TcTauType] -> TcM () +-- Precondition: lists must be same length +-- Having the caller check gives better error messages +-- Actually the caller neve does need to check; see Note [Tycon app] +unifyTauTyLists r1 [] r2 [] = returnM () +unifyTauTyLists r1 (ty1:tys1) r2 (ty2:tys2) = uTys r1 ty1 ty1 r2 ty2 ty2 `thenM_` + unifyTauTyLists r1 tys1 r2 tys2 +unifyTauTyLists r1 ty1s r2 ty2s = panic "Unify.unifyTauTyLists: mismatched type lists!" \end{code} @unifyTauTyList@ takes a single list of @TauType@s and unifies them @@ -608,56 +671,59 @@ de-synonym'd version. This way we get better error messages. We call the first one \tr{ps_ty1}, \tr{ps_ty2} for ``possible synomym''. \begin{code} -uTys :: TcTauType -> TcTauType -- Error reporting ty1 and real ty1 +uTys :: Bool -- Allow refinements to ty1 + -> TcTauType -> TcTauType -- Error reporting ty1 and real ty1 -- ty1 is the *expected* type - + -> Bool -- Allow refinements to ty2 -> TcTauType -> TcTauType -- Error reporting ty2 and real ty2 -- ty2 is the *actual* type -> TcM () -- Always expand synonyms (see notes at end) -- (this also throws away FTVs) -uTys ps_ty1 (NoteTy n1 ty1) ps_ty2 ty2 = uTys ps_ty1 ty1 ps_ty2 ty2 -uTys ps_ty1 ty1 ps_ty2 (NoteTy n2 ty2) = uTys ps_ty1 ty1 ps_ty2 ty2 +uTys r1 ps_ty1 (NoteTy n1 ty1) r2 ps_ty2 ty2 = uTys r1 ps_ty1 ty1 r2 ps_ty2 ty2 +uTys r1 ps_ty1 ty1 r2 ps_ty2 (NoteTy n2 ty2) = uTys r1 ps_ty1 ty1 r2 ps_ty2 ty2 -- Variables; go for uVar -uTys ps_ty1 (TyVarTy tyvar1) ps_ty2 ty2 = uVar False tyvar1 ps_ty2 ty2 -uTys ps_ty1 ty1 ps_ty2 (TyVarTy tyvar2) = uVar True tyvar2 ps_ty1 ty1 +uTys r1 ps_ty1 (TyVarTy tyvar1) r2 ps_ty2 ty2 = uVar False r1 tyvar1 r2 ps_ty2 ty2 +uTys r1 ps_ty1 ty1 r2 ps_ty2 (TyVarTy tyvar2) = uVar True r2 tyvar2 r1 ps_ty1 ty1 -- "True" means args swapped -- Predicates -uTys _ (PredTy (IParam n1 t1)) _ (PredTy (IParam n2 t2)) - | n1 == n2 = uTys t1 t1 t2 t2 -uTys _ (PredTy (ClassP c1 tys1)) _ (PredTy (ClassP c2 tys2)) - | c1 == c2 = unifyTauTyLists tys1 tys2 +uTys r1 _ (PredTy (IParam n1 t1)) r2 _ (PredTy (IParam n2 t2)) + | n1 == n2 = uTys r1 t1 t1 r2 t2 t2 +uTys r1 _ (PredTy (ClassP c1 tys1)) r2 _ (PredTy (ClassP c2 tys2)) + | c1 == c2 = unifyTauTyLists r1 tys1 r2 tys2 + -- Guaranteed equal lengths because the kinds check -- Functions; just check the two parts -uTys _ (FunTy fun1 arg1) _ (FunTy fun2 arg2) - = uTys fun1 fun1 fun2 fun2 `thenM_` uTys arg1 arg1 arg2 arg2 +uTys r1 _ (FunTy fun1 arg1) r2 _ (FunTy fun2 arg2) + = uTys r1 fun1 fun1 r2 fun2 fun2 `thenM_` uTys r1 arg1 arg1 r2 arg2 arg2 -- NewType constructors must match -uTys _ (NewTcApp tc1 tys1) _ (NewTcApp tc2 tys2) - | tc1 == tc2 = unifyTauTyLists tys1 tys2 +uTys r1 _ (NewTcApp tc1 tys1) r2 _ (NewTcApp tc2 tys2) + | tc1 == tc2 = unifyTauTyLists r1 tys1 r2 tys2 + -- See Note [TyCon app] -- Ordinary type constructors must match -uTys ps_ty1 (TyConApp con1 tys1) ps_ty2 (TyConApp con2 tys2) - | con1 == con2 && equalLength tys1 tys2 - = unifyTauTyLists tys1 tys2 +uTys r1 ps_ty1 (TyConApp con1 tys1) r2 ps_ty2 (TyConApp con2 tys2) + | con1 == con2 = unifyTauTyLists r1 tys1 r2 tys2 + -- See Note [TyCon app] -- Applications need a bit of care! -- They can match FunTy and TyConApp, so use splitAppTy_maybe -- NB: we've already dealt with type variables and Notes, -- so if one type is an App the other one jolly well better be too -uTys ps_ty1 (AppTy s1 t1) ps_ty2 ty2 +uTys r1 ps_ty1 (AppTy s1 t1) r2 ps_ty2 ty2 = case tcSplitAppTy_maybe ty2 of - Just (s2,t2) -> uTys s1 s1 s2 s2 `thenM_` uTys t1 t1 t2 t2 + Just (s2,t2) -> uTys r1 s1 s1 r2 s2 s2 `thenM_` uTys r1 t1 t1 r2 t2 t2 Nothing -> unifyMisMatch ps_ty1 ps_ty2 -- Now the same, but the other way round -- Don't swap the types, because the error messages get worse -uTys ps_ty1 ty1 ps_ty2 (AppTy s2 t2) +uTys r1 ps_ty1 ty1 r2 ps_ty2 (AppTy s2 t2) = case tcSplitAppTy_maybe ty1 of - Just (s1,t1) -> uTys s1 s1 s2 s2 `thenM_` uTys t1 t1 t2 t2 + Just (s1,t1) -> uTys r1 s1 s1 r2 s2 s2 `thenM_` uTys r1 t1 t1 r2 t2 t2 Nothing -> unifyMisMatch ps_ty1 ps_ty2 -- Not expecting for-alls in unification @@ -665,9 +731,19 @@ uTys ps_ty1 ty1 ps_ty2 (AppTy s2 t2) -- than a panic message! -- Anything else fails -uTys ps_ty1 ty1 ps_ty2 ty2 = unifyMisMatch ps_ty1 ps_ty2 +uTys r1 ps_ty1 ty1 r2 ps_ty2 ty2 = unifyMisMatch ps_ty1 ps_ty2 \end{code} +Note [Tycon app] +~~~~~~~~~~~~~~~~ +When we find two TyConApps, the argument lists are guaranteed equal +length. Reason: intially the kinds of the two types to be unified is +the same. The only way it can become not the same is when unifying two +AppTys (f1 a1):=:(f2 a2). In that case there can't be a TyConApp in +the f1,f2 (because it'd absorb the app). If we unify f1:=:f2 first, +which we do, that ensures that f1,f2 have the same kind; and that +means a1,a2 have the same kind. And now the argument repeats. + Notes on synonyms ~~~~~~~~~~~~~~~~~ @@ -735,48 +811,44 @@ back into @uTys@ if it turns out that the variable is already bound. \begin{code} uVar :: Bool -- False => tyvar is the "expected" -- True => ty is the "expected" thing + -> Bool -- True, allow refinements to tv1, False don't -> TcTyVar + -> Bool -- Allow refinements to ty2? -> TcTauType -> TcTauType -- printing and real versions -> TcM () -uVar swapped tv1 ps_ty2 ty2 +uVar swapped r1 tv1 r2 ps_ty2 ty2 = traceTc (text "uVar" <+> ppr swapped <+> ppr tv1 <+> (ppr ps_ty2 $$ ppr ty2)) `thenM_` - getTcTyVar tv1 `thenM` \ maybe_ty1 -> - case maybe_ty1 of - Just ty1 | swapped -> uTys ps_ty2 ty2 ty1 ty1 -- Swap back - | otherwise -> uTys ty1 ty1 ps_ty2 ty2 -- Same order - other -> uUnboundVar swapped tv1 ps_ty2 ty2 + condLookupTcTyVar r1 tv1 `thenM` \ details -> + case details of + IndirectTv r1' ty1 | swapped -> uTys r2 ps_ty2 ty2 r1' ty1 ty1 -- Swap back + | otherwise -> uTys r1' ty1 ty1 r2 ps_ty2 ty2 -- Same order + FlexiTv -> uFlexiVar swapped tv1 r2 ps_ty2 ty2 + RigidTv -> uRigidVar swapped tv1 r2 ps_ty2 ty2 -- Expand synonyms; ignore FTVs -uUnboundVar swapped tv1 ps_ty2 (NoteTy n2 ty2) - = uUnboundVar swapped tv1 ps_ty2 ty2 - - - -- The both-type-variable case -uUnboundVar swapped tv1 ps_ty2 ty2@(TyVarTy tv2) - +uFlexiVar :: Bool -> TcTyVar -> + Bool -> -- Allow refinements to ty2 + TcTauType -> TcTauType -> TcM () +-- Invariant: tv1 is Flexi +uFlexiVar swapped tv1 r2 ps_ty2 (NoteTy n2 ty2) + = uFlexiVar swapped tv1 r2 ps_ty2 ty2 + +uFlexiVar swapped tv1 r2 ps_ty2 ty2@(TyVarTy tv2) -- Same type variable => no-op | tv1 == tv2 = returnM () -- Distinct type variables | otherwise - = getTcTyVar tv2 `thenM` \ maybe_ty2 -> - case maybe_ty2 of - Just ty2' -> uUnboundVar swapped tv1 ty2' ty2' - - Nothing | update_tv2 - -- It should always be the case that either k1 <: k2 or k2 <: k1 - -- Reason: a type variable never gets the kinds (#) or # - - -> ASSERT2( k1 `isSubKind` k2, (ppr tv1 <+> ppr k1) $$ (ppr tv2 <+> ppr k2) ) - putTcTyVar tv2 (TyVarTy tv1) `thenM_` - returnM () - - | otherwise - -> ASSERT2( k2 `isSubKind` k1, (ppr tv2 <+> ppr k2) $$ (ppr tv1 <+> ppr k1) ) - putTcTyVar tv1 ps_ty2 `thenM_` - returnM () + = condLookupTcTyVar r2 tv2 `thenM` \ details -> + case details of + IndirectTv b ty2' -> uFlexiVar swapped tv1 b ty2' ty2' + FlexiTv | update_tv2 -> putMetaTyVar tv2 (TyVarTy tv1) + | otherwise -> updateFlexi swapped tv1 ty2 + RigidTv -> updateFlexi swapped tv1 ty2 + -- Note that updateFlexi does a sub-kind check + -- We might unify (a b) with (c d) where b::*->* and d::*; this should fail where k1 = tyVarKind tv1 k2 = tyVarKind tv2 @@ -786,28 +858,47 @@ uUnboundVar swapped tv1 ps_ty2 ty2@(TyVarTy tv2) -- The "nicer to" part only applies if the two kinds are the same, -- so we can choose which to do. - nicer_to_update_tv2 = isUserTyVar tv1 - -- Don't unify a signature type variable if poss - || isSystemName (varName tv2) - -- Try to update sys-y type variables in preference to sig-y ones - - -- Second one isn't a type variable -uUnboundVar swapped tv1 ps_ty2 non_var_ty2 - = -- Check that tv1 isn't a type-signature type variable - checkM (not (isSkolemTyVar tv1)) - (failWithTcM (unifyWithSigErr tv1 ps_ty2)) `thenM_` + nicer_to_update_tv2 = isSystemName (varName tv2) + -- Try to update sys-y type variables in preference to sig-y ones - -- Do the occurs check, and check that we are not + -- First one is flexi, second one isn't a type variable +uFlexiVar swapped tv1 r2 ps_ty2 non_var_ty2 + = -- Do the occurs check, and check that we are not -- unifying a type variable with a polytype -- Returns a zonked type ready for the update - checkValue tv1 ps_ty2 non_var_ty2 `thenM` \ ty2 -> + do { ty2 <- checkValue tv1 r2 ps_ty2 non_var_ty2 + ; updateFlexi swapped tv1 ty2 } + +-- Ready to update tv1, which is flexi; occurs check is done +updateFlexi swapped tv1 ty2 + = do { checkKinds swapped tv1 ty2 + ; putMetaTyVar tv1 ty2 } + - -- Check that the kinds match - checkKinds swapped tv1 ty2 `thenM_` +uRigidVar :: Bool -> TcTyVar + -> Bool -> -- Allow refinements to ty2 + TcTauType -> TcTauType -> TcM () +-- Invariant: tv1 is Rigid +uRigidVar swapped tv1 r2 ps_ty2 (NoteTy n2 ty2) + = uRigidVar swapped tv1 r2 ps_ty2 ty2 + + -- The both-type-variable case +uRigidVar swapped tv1 r2 ps_ty2 ty2@(TyVarTy tv2) + -- Same type variable => no-op + | tv1 == tv2 + = returnM () - -- Perform the update - putTcTyVar tv1 ty2 `thenM_` - returnM () + -- Distinct type variables + | otherwise + = condLookupTcTyVar r2 tv2 `thenM` \ details -> + case details of + IndirectTv b ty2' -> uRigidVar swapped tv1 b ty2' ty2' + FlexiTv -> updateFlexi swapped tv2 (TyVarTy tv1) + RigidTv -> unifyMisMatch (TyVarTy tv1) (TyVarTy tv2) + + -- Second one isn't a type variable +uRigidVar swapped tv1 r2 ps_ty2 non_var_ty2 + = unifyMisMatch (TyVarTy tv1) ps_ty2 \end{code} \begin{code} @@ -833,7 +924,7 @@ checkKinds swapped tv1 ty2 \end{code} \begin{code} -checkValue tv1 ps_ty2 non_var_ty2 +checkValue tv1 r2 ps_ty2 non_var_ty2 -- Do the occurs check, and check that we are not -- unifying a type variable with a polytype -- Return the type to update the type variable with, or fail @@ -857,12 +948,12 @@ checkValue tv1 ps_ty2 non_var_ty2 -- Rather, we should bind t to () (= non_var_ty2). -- -- That's why we have this two-state occurs-check - = zonkTcType ps_ty2 `thenM` \ ps_ty2' -> + = zonk_tc_type r2 ps_ty2 `thenM` \ ps_ty2' -> case okToUnifyWith tv1 ps_ty2' of { Nothing -> returnM ps_ty2' ; -- Success other -> - zonkTcType non_var_ty2 `thenM` \ non_var_ty2' -> + zonk_tc_type r2 non_var_ty2 `thenM` \ non_var_ty2' -> case okToUnifyWith tv1 non_var_ty2' of Nothing -> -- This branch rarely succeeds, except in strange cases -- like that in the example above @@ -870,6 +961,11 @@ checkValue tv1 ps_ty2 non_var_ty2 Just problem -> failWithTcM (unifyCheck problem tv1 ps_ty2') } + where + zonk_tc_type refine ty + = zonkType (\tv -> return (TyVarTy tv)) refine ty + -- We may already be inside a wobbly type t2, and + -- should take that into account here data Problem = OccurCheck | NotMonoType @@ -1061,7 +1157,7 @@ unifyKindCtxt swapped tv1 ty2 tidy_env -- not swapped => tv1 expected, ty2 infer -- tv1 and ty2 are zonked already = returnM msg where - msg = (env2, ptext SLIT("When matching types") <+> + msg = (env2, ptext SLIT("When matching the kinds of") <+> sep [quotes pp_expected <+> ptext SLIT("and"), quotes pp_actual]) (pp_expected, pp_actual) | swapped = (pp2, pp1) @@ -1072,24 +1168,26 @@ unifyKindCtxt swapped tv1 ty2 tidy_env -- not swapped => tv1 expected, ty2 infer pp2 = ppr ty2' <+> dcolon <+> ppr (typeKind ty2) unifyMisMatch ty1 ty2 - = zonkTcType ty1 `thenM` \ ty1' -> - zonkTcType ty2 `thenM` \ ty2' -> - let - (env, [tidy_ty1, tidy_ty2]) = tidyOpenTypes emptyTidyEnv [ty1',ty2'] - msg = hang (ptext SLIT("Couldn't match")) - 2 (sep [quotes (ppr tidy_ty1), - ptext SLIT("against"), - quotes (ppr tidy_ty2)]) + = do { (env1, pp1, extra1) <- ppr_ty emptyTidyEnv ty1 + ; (env2, pp2, extra2) <- ppr_ty env1 ty2 + ; let msg = sep [sep [ptext SLIT("Couldn't match") <+> pp1, nest 7 (ptext SLIT("against") <+> pp2)], + nest 2 extra1, nest 2 extra2] in - failWithTcM (env, msg) - - -unifyWithSigErr tyvar ty - = (env2, hang (ptext SLIT("Cannot unify the type-signature variable") <+> quotes (ppr tidy_tyvar)) - 2 (ptext SLIT("with the type") <+> quotes (ppr tidy_ty))) + failWithTcM (env2, msg) } + +ppr_ty :: TidyEnv -> TcType -> TcM (TidyEnv, SDoc, SDoc) +ppr_ty env ty + = do { ty' <- zonkTcType ty + ; let (env1,tidy_ty) = tidyOpenType env ty' + simple_result = (env1, quotes (ppr tidy_ty), empty) + ; case tidy_ty of + TyVarTy tv + | isSkolemTyVar tv -> return (env1, pp_rigid tv, + pprSkolemTyVar tv) + | otherwise -> return simple_result + other -> return simple_result } where - (env1, tidy_tyvar) = tidyOpenTyVar emptyTidyEnv tyvar - (env2, tidy_ty) = tidyOpenType env1 ty + pp_rigid tv = ptext SLIT("the rigid variable") <+> quotes (ppr tv) unifyCheck problem tyvar ty = (env2, hang msg @@ -1226,67 +1324,58 @@ So we revert to ordinary type variables for signatures, and try to give a helpful message in checkSigTyVars. \begin{code} -checkSigTyVars :: [TcTyVar] -> TcM [TcTyVar] +checkSigTyVars :: [TcTyVar] -> TcM () checkSigTyVars sig_tvs = check_sig_tyvars emptyVarSet sig_tvs -checkSigTyVarsWrt :: TcTyVarSet -> [TcTyVar] -> TcM [TcTyVar] +checkSigTyVarsWrt :: TcTyVarSet -> [TcTyVar] -> TcM () checkSigTyVarsWrt extra_tvs sig_tvs = zonkTcTyVarsAndFV (varSetElems extra_tvs) `thenM` \ extra_tvs' -> check_sig_tyvars extra_tvs' sig_tvs check_sig_tyvars - :: TcTyVarSet -- Global type variables. The universally quantified - -- tyvars should not mention any of these - -- Guaranteed already zonked. - -> [TcTyVar] -- Universally-quantified type variables in the signature - -- Not guaranteed zonked. - -> TcM [TcTyVar] -- Zonked signature type variables + :: TcTyVarSet -- Global type variables. The universally quantified + -- tyvars should not mention any of these + -- Guaranteed already zonked. + -> [TcTyVar] -- Universally-quantified type variables in the signature + -- Not guaranteed zonked. + -> TcM () check_sig_tyvars extra_tvs [] - = returnM [] + = returnM () check_sig_tyvars extra_tvs sig_tvs - = zonkTcTyVars sig_tvs `thenM` \ sig_tys -> - tcGetGlobalTyVars `thenM` \ gbl_tvs -> - let - env_tvs = gbl_tvs `unionVarSet` extra_tvs - in - traceTc (text "check_sig_tyvars" <+> (vcat [text "sig_tys" <+> ppr sig_tys, + = do { gbl_tvs <- tcGetGlobalTyVars + ; traceTc (text "check_sig_tyvars" <+> (vcat [text "sig_tys" <+> ppr sig_tvs, text "gbl_tvs" <+> ppr gbl_tvs, - text "extra_tvs" <+> ppr extra_tvs])) `thenM_` + text "extra_tvs" <+> ppr extra_tvs])) - checkM (allDistinctTyVars sig_tys env_tvs) - (complain sig_tys env_tvs) `thenM_` - - returnM (map (tcGetTyVar "checkSigTyVars") sig_tys) + -- Check that that the signature type vars are not free in the envt + ; let env_tvs = gbl_tvs `unionVarSet` extra_tvs + ; checkM (not (mkVarSet sig_tvs `intersectsVarSet` env_tvs)) + (complain sig_tvs env_tvs) + ; ASSERT( all isSkolemTyVar sig_tvs ) + return () } where - complain sig_tys globals + complain sig_tvs globals = -- "check" checks each sig tyvar in turn foldlM check - (env2, emptyVarEnv, []) - (tidy_tvs `zip` tidy_tys) `thenM` \ (env3, _, msgs) -> + (env, emptyVarEnv, []) + tidy_tvs `thenM` \ (env2, _, msgs) -> - failWithTcM (env3, main_msg $$ nest 2 (vcat msgs)) + failWithTcM (env2, main_msg $$ nest 2 (vcat msgs)) where - (env1, tidy_tvs) = tidyOpenTyVars emptyTidyEnv sig_tvs - (env2, tidy_tys) = tidyOpenTypes env1 sig_tys + (env, tidy_tvs) = tidyOpenTyVars emptyTidyEnv sig_tvs main_msg = ptext SLIT("Inferred type is less polymorphic than expected") - check (tidy_env, acc, msgs) (sig_tyvar,ty) + check (tidy_env, acc, msgs) tv -- sig_tyvar is from the signature; -- ty is what you get if you zonk sig_tyvar and then tidy it -- -- acc maps a zonked type variable back to a signature type variable - = case tcGetTyVar_maybe ty of { - Nothing -> -- Error (a)! - returnM (tidy_env, acc, unify_msg sig_tyvar (quotes (ppr ty)) : msgs) ; - - Just tv -> - - case lookupVarEnv acc tv of { + = case lookupVarEnv acc tv of { Just sig_tyvar' -> -- Error (b)! - returnM (tidy_env, acc, unify_msg sig_tyvar thing : msgs) + returnM (tidy_env, acc, unify_msg tv thing : msgs) where thing = ptext SLIT("another quantified type variable") <+> quotes (ppr sig_tyvar') @@ -1297,30 +1386,30 @@ check_sig_tyvars extra_tvs sig_tvs -- Game plan: -- get the local TcIds and TyVars from the environment, -- and pass them to find_globals (they might have tv free) - then findGlobals (unitVarSet tv) tidy_env `thenM` \ (tidy_env1, globs) -> - returnM (tidy_env1, acc, escape_msg sig_tyvar tv globs : msgs) + then + findGlobals (unitVarSet tv) tidy_env `thenM` \ (tidy_env1, globs) -> + -- This rigid type variable has escaped into the envt + -- We make it flexi so that subequent uses of these + -- variables don't give rise to a cascade of further errors + returnM (tidy_env1, acc, escape_msg tv globs : msgs) else -- All OK - returnM (tidy_env, extendVarEnv acc tv sig_tyvar, msgs) - }} + returnM (tidy_env, extendVarEnv acc tv tv, msgs) + } \end{code} \begin{code} ----------------------- -escape_msg sig_tv tv globs +escape_msg sig_tv globs = mk_msg sig_tv <+> ptext SLIT("escapes") $$ if notNull globs then - vcat [pp_it <+> ptext SLIT("is mentioned in the environment:"), + vcat [ptext SLIT("It is mentioned in the environment:"), nest 2 (vcat globs)] else empty -- Sigh. It's really hard to give a good error message -- all the time. One bad case is an existential pattern match. -- We rely on the "When..." context to help. - where - pp_it | sig_tv /= tv = ptext SLIT("It unifies with") <+> quotes (ppr tv) <> comma <+> ptext SLIT("which") - | otherwise = ptext SLIT("It") - unify_msg tv thing = mk_msg tv <+> ptext SLIT("is unified with") <+> thing mk_msg tv = ptext SLIT("Quantified type variable") <+> quotes (ppr tv) diff --git a/ghc/compiler/types/FunDeps.lhs b/ghc/compiler/types/FunDeps.lhs index 9102b682b3..8ec40841ab 100644 --- a/ghc/compiler/types/FunDeps.lhs +++ b/ghc/compiler/types/FunDeps.lhs @@ -16,11 +16,10 @@ module FunDeps ( import Name ( getSrcLoc ) import Var ( Id, TyVar ) import Class ( Class, FunDep, classTvsFds ) -import Subst ( mkSubst, emptyInScopeSet, substTy ) -import TcType ( Type, ThetaType, PredType(..), - predTyUnique, mkClassPred, tyVarsOfTypes, tyVarsOfPred, - unifyTyListsX, unifyExtendTyListsX, tcEqType - ) +import Unify ( unifyTys, unifyTysX ) +import Type ( mkTvSubst, substTy ) +import TcType ( Type, ThetaType, PredType(..), tcEqType, + predTyUnique, mkClassPred, tyVarsOfTypes, tyVarsOfPred ) import VarSet import VarEnv import Outputable @@ -299,19 +298,21 @@ checkClsFD qtvs fd clas_tvs tys1 tys2 -- -- We can instantiate x to t1, and then we want to force -- (Tree x) [t1/x] :=: t2 - --- We use 'unify' even though we are often only matching --- unifyTyListsX will only bind variables in qtvs, so it's OK! - = case unifyTyListsX qtvs ls1 ls2 of +-- +-- The same function is also used from InstEnv.badFunDeps, when we need +-- to *unify*; in which case the qtvs are the variables of both ls1 and ls2. +-- However unifying with the qtvs being the left-hand lot *is* just matching, +-- so we can call unifyTys in both cases + = case unifyTys qtvs ls1 ls2 of Nothing -> [] - Just unif | maybeToBool (unifyExtendTyListsX qtvs unif rs1 rs2) + Just unif | maybeToBool (unifyTysX qtvs unif rs1 rs2) -- Don't include any equations that already hold. -- Reason: then we know if any actual improvement has happened, -- in which case we need to iterate the solver -- In making this check we must taking account of the fact that any -- qtvs that aren't already instantiated can be instantiated to anything -- at all - -- NB: qtvs, not qtvs' because unifyExtendTyListsX only tries to + -- NB: qtvs, not qtvs' because matchTysX only tries to -- look template tyvars up in the substitution -> [] @@ -323,10 +324,9 @@ checkClsFD qtvs fd clas_tvs tys1 tys2 -- executed. What we're doing instead is recording the partial -- work of the ls1/ls2 unification leaving a smaller unification problem where - full_unif = mkSubst emptyInScopeSet unif - -- No for-alls in sight; hmm + full_unif = mkTvSubst unif - qtvs' = filterVarSet (\v -> not (v `elemSubstEnv` unif)) qtvs + qtvs' = filterVarSet (\v -> not (v `elemVarEnv` unif)) qtvs -- qtvs' are the quantified type variables -- that have not been substituted out -- diff --git a/ghc/compiler/types/Generics.lhs b/ghc/compiler/types/Generics.lhs index dc027164b2..0063140322 100644 --- a/ghc/compiler/types/Generics.lhs +++ b/ghc/compiler/types/Generics.lhs @@ -11,7 +11,7 @@ import Type ( Type, isUnLiftedType, tyVarsOfType, tyVarsOfTypes, ) import TcHsSyn ( mkSimpleHsAlt ) import TcType ( tcSplitTyConApp_maybe, tcSplitSigmaTy, tcSplitSigmaTy, isTauTy ) -import DataCon ( DataCon, dataConOrigArgTys, isExistentialDataCon, +import DataCon ( DataCon, dataConOrigArgTys, isVanillaDataCon, dataConSourceArity ) import TyCon ( TyCon, tyConName, tyConDataCons, @@ -228,7 +228,7 @@ canDoGenerics data_cons = not (any bad_con data_cons) -- See comment below && not (null data_cons) -- No values of the type where - bad_con dc = any bad_arg_type (dataConOrigArgTys dc) || isExistentialDataCon dc + bad_con dc = any bad_arg_type (dataConOrigArgTys dc) || not (isVanillaDataCon dc) -- If any of the constructor has an unboxed type as argument, -- then we can't build the embedding-projection pair, because -- it relies on instantiating *polymorphic* sum and product types @@ -253,11 +253,11 @@ type FromAlt = (LPat RdrName, LHsExpr RdrName) mkTyConGenericBinds :: TyCon -> LHsBinds RdrName mkTyConGenericBinds tycon = unitBag (L loc (FunBind (L loc from_RDR) False {- Not infix -} - [mkSimpleHsAlt pat rhs | (pat,rhs) <- from_alts])) + (mkMatchGroup [mkSimpleHsAlt pat rhs | (pat,rhs) <- from_alts]))) `unionBags` unitBag (L loc (FunBind (L loc to_RDR) False - [mkSimpleHsAlt to_pat to_body])) + (mkMatchGroup [mkSimpleHsAlt to_pat to_body]))) where loc = srcLocSpan (getSrcLoc tycon) datacons = tyConDataCons tycon @@ -305,8 +305,8 @@ mk_sum_stuff us datacons = (wrap inlDataCon_RDR l_from_alts ++ wrap inrDataCon_RDR r_from_alts, nlVarPat to_arg, noLoc (HsCase (nlHsVar to_arg) - [mkSimpleHsAlt (nlConPat inlDataCon_RDR [l_to_pat]) l_to_body, - mkSimpleHsAlt (nlConPat inrDataCon_RDR [r_to_pat]) r_to_body])) + (mkMatchGroup [mkSimpleHsAlt (nlConPat inlDataCon_RDR [l_to_pat]) l_to_body, + mkSimpleHsAlt (nlConPat inrDataCon_RDR [r_to_pat]) r_to_body]))) where (l_datacons, r_datacons) = splitInHalf datacons (l_from_alts, l_to_pat, l_to_body) = mk_sum_stuff us' l_datacons @@ -364,8 +364,9 @@ mk_prod_stuff us arg_vars -- Two or more = (us'', nlHsApps crossDataCon_RDR [l_alt_rhs, r_alt_rhs], nlVarPat to_arg, - \x -> noLoc (HsCase (nlHsVar to_arg) - [mkSimpleHsAlt pat (l_to_body_fn (r_to_body_fn x))])) +-- gaw 2004 FIX? + \x -> noLoc (HsCase (nlHsVar to_arg) + (mkMatchGroup [mkSimpleHsAlt pat (l_to_body_fn (r_to_body_fn x))]))) where to_arg = mkGenericLocal us (l_arg_vars, r_arg_vars) = splitInHalf arg_vars diff --git a/ghc/compiler/types/InstEnv.lhs b/ghc/compiler/types/InstEnv.lhs index b7a356b610..974f960254 100644 --- a/ghc/compiler/types/InstEnv.lhs +++ b/ghc/compiler/types/InstEnv.lhs @@ -17,13 +17,13 @@ module InstEnv ( #include "HsVersions.h" import Class ( Class, classTvsFds ) -import Var ( Id, isTcTyVar ) +import Var ( Id ) import VarSet -import VarEnv +import Type ( TvSubstEnv ) import TcType ( Type, tcTyConAppTyCon, tcIsTyVarTy, - tcSplitDFunTy, tyVarsOfTypes, isExistentialTyVar, - matchTys, unifyTyListsX + tcSplitDFunTy, tyVarsOfTypes, isSkolemTyVar ) +import Unify ( matchTys, unifyTys ) import FunDeps ( checkClsFD ) import TyCon ( TyCon ) import Outputable @@ -271,7 +271,7 @@ lookupInstEnv :: DynFlags -> (InstEnv -- External package inst-env ,InstEnv) -- Home-package inst-env -> Class -> [Type] -- What we are looking for - -> ([(TyVarSubstEnv, InstEnvElt)], -- Successful matches + -> ([(TvSubstEnv, InstEnvElt)], -- Successful matches [Id]) -- These don't match but do unify -- The second component of the tuple happens when we look up -- Foo [a] @@ -303,7 +303,7 @@ lookupInstEnv dflags (pkg_ie, home_ie) cls tys lookup_inst_env :: InstEnv -- The envt -> Class -> [Type] -- What we are looking for -> Bool -- All the [Type] are tyvars - -> ([(TyVarSubstEnv, InstEnvElt)], -- Successful matches + -> ([(TvSubstEnv, InstEnvElt)], -- Successful matches [Id]) -- These don't match but do unify lookup_inst_env env key_cls key_tys key_all_tvs = case lookupUFM env key_cls of @@ -315,7 +315,7 @@ lookup_inst_env env key_cls key_tys key_all_tvs | otherwise -> find insts [] [] where key_vars = filterVarSet not_existential (tyVarsOfTypes key_tys) - not_existential tv = not (isTcTyVar tv && isExistentialTyVar tv) + not_existential tv = not (isSkolemTyVar tv) -- The key_tys can contain skolem constants, and we can guarantee that those -- are never going to be instantiated to anything, so we should not involve -- them in the unification test. Example: @@ -332,20 +332,22 @@ lookup_inst_env env key_cls key_tys key_all_tvs find [] ms us = (ms, us) find (item@(tpl_tyvars, tpl, dfun_id) : rest) ms us = case matchTys tpl_tyvars tpl key_tys of - Just (subst, leftovers) -> ASSERT( null leftovers ) - find rest ((subst,item):ms) us + Just subst -> find rest ((subst,item):ms) us Nothing -- Does not match, so next check whether the things unify -- [see notes about overlapping instances above] - -> ASSERT( not (key_vars `intersectsVarSet` tpl_tyvars) ) + -> ASSERT2( not (key_vars `intersectsVarSet` tpl_tyvars), + (ppr key_cls <+> ppr key_tys <+> ppr key_all_tvs) $$ + (ppr dfun_id <+> ppr tpl_tyvars <+> ppr tpl) + ) -- Unification will break badly if the variables overlap -- They shouldn't because we allocate separate uniques for them - case unifyTyListsX (key_vars `unionVarSet` tpl_tyvars) key_tys tpl of + case unifyTys (key_vars `unionVarSet` tpl_tyvars) key_tys tpl of Just _ -> find rest ms (dfun_id:us) Nothing -> find rest ms us -insert_overlapping :: (TyVarSubstEnv, InstEnvElt) -> [(TyVarSubstEnv, InstEnvElt)] - -> [(TyVarSubstEnv, InstEnvElt)] +insert_overlapping :: (TvSubstEnv, InstEnvElt) -> [(TvSubstEnv, InstEnvElt)] + -> [(TvSubstEnv, InstEnvElt)] -- Add a new solution, knocking out strictly less specific ones insert_overlapping new_item [] = [new_item] insert_overlapping new_item (item:items) diff --git a/ghc/compiler/types/Kind.lhs b/ghc/compiler/types/Kind.lhs index 4c32ce15e6..336e9b6c7c 100644 --- a/ghc/compiler/types/Kind.lhs +++ b/ghc/compiler/types/Kind.lhs @@ -97,11 +97,6 @@ finding the GLB of the two. Since the partial order is a tree, they only have a glb if one is a sub-kind of the other. In that case, we bind the less-informative one to the more informative one. Neat, eh? -In the olden days, when we generalise, we make generic type variables -whose kind is simple. So generic type variables (other than built-in -constants like 'error') always have simple kinds. But I don't see any -reason to do that any more (TcMType.zapTcTyVarToTyVar). - \begin{code} liftedTypeKind = LiftedTypeKind @@ -165,6 +160,18 @@ isSubKind k1 k2 = False defaultKind :: Kind -> Kind -- Used when generalising: default kind '?' and '??' to '*' +-- +-- When we generalise, we make generic type variables whose kind is +-- simple (* or *->* etc). So generic type variables (other than +-- built-in constants like 'error') always have simple kinds. This is important; +-- consider +-- f x = True +-- We want f to get type +-- f :: forall (a::*). a -> Bool +-- Not +-- f :: forall (a::??). a -> Bool +-- because that would allow a call like (f 3#) as well as (f True), +--and the calling conventions differ. This defaulting is done in TcMType.zonkTcTyVarBndr. defaultKind OpenTypeKind = LiftedTypeKind defaultKind ArgTypeKind = LiftedTypeKind defaultKind kind = kind diff --git a/ghc/compiler/types/TyCon.lhs b/ghc/compiler/types/TyCon.lhs index 51b81d6e99..96e10465c3 100644 --- a/ghc/compiler/types/TyCon.lhs +++ b/ghc/compiler/types/TyCon.lhs @@ -5,7 +5,7 @@ \begin{code} module TyCon( - TyCon, ArgVrcs, + TyCon, ArgVrcs, FieldLabel, PrimRep(..), tyConPrimRep, @@ -33,9 +33,9 @@ module TyCon( tyConUnique, tyConTyVars, tyConArgVrcs, - algTyConRhs, tyConDataCons, tyConDataCons_maybe, tyConFamilySize, - tyConSelIds, - tyConTheta, + algTcRhs, tyConDataCons, tyConDataCons_maybe, tyConFamilySize, + tyConFields, tyConSelIds, + tyConStupidTheta, tyConArity, isClassTyCon, tyConClass_maybe, getSynTyConDefn, @@ -53,7 +53,7 @@ import {-# SOURCE #-} TypeRep ( Type, PredType ) -- Should just be Type(Type), but this fails due to bug present up to -- and including 4.02 involving slurping of hi-boot files. Bug is now fixed. -import {-# SOURCE #-} DataCon ( DataCon, isExistentialDataCon ) +import {-# SOURCE #-} DataCon ( DataCon, isVanillaDataCon ) import Var ( TyVar, Id ) @@ -90,21 +90,27 @@ data TyCon tyConKind :: Kind, tyConArity :: Arity, - tyConTyVars :: [TyVar], - argVrcs :: ArgVrcs, - algTyConTheta :: [PredType], + tyConTyVars :: [TyVar], -- Scopes over (a) the [PredType] in DataTyCon + -- (b) the cached types in NewTyCon + -- (c) the types in algTcFields + -- But not over the data constructors + argVrcs :: ArgVrcs, - selIds :: [Id], -- Its record selectors (if any) + algTcFields :: [(FieldLabel, Type, Id)], + -- Its fields (empty if none): + -- * field name + -- * its type (scoped over tby tyConTyVars) + -- * record selector (name = field name) - algRhs :: AlgTyConRhs, -- Data constructors in here + algTcRhs :: AlgTyConRhs, -- Data constructors in here - algTyConRec :: RecFlag, -- Tells whether the data type is part of + algTcRec :: RecFlag, -- Tells whether the data type is part of -- a mutually-recursive group or not hasGenerics :: Bool, -- True <=> generic to/from functions are available -- (in the exports of the data type's source module) - algTyConClass :: Maybe Class + algTcClass :: Maybe Class -- Just cl if this tycon came from a class declaration } @@ -149,6 +155,8 @@ data TyCon argVrcs :: ArgVrcs } +type FieldLabel = Name + type ArgVrcs = [(Bool,Bool)] -- Tyvar variance info: [(occPos,occNeg)] -- [] means "no information, assume the worst" @@ -159,6 +167,13 @@ data AlgTyConRhs -- an hi file | DataTyCon + (Maybe [PredType]) -- Just theta => this tycon was declared in H98 syntax + -- with the specified "stupid theta" + -- e.g. data Ord a => T a = ... + -- Nothing => this tycon was declared by giving the + -- type signatures for each constructor + -- (new GADT stuff) + -- e.g. data T a where { ... } [DataCon] -- The constructors; can be empty if the user declares -- the type to have no constructors Bool -- Cached: True <=> an enumeration type @@ -184,9 +199,9 @@ data AlgTyConRhs -- newtypes. visibleDataCons :: AlgTyConRhs -> [DataCon] -visibleDataCons AbstractTyCon = [] -visibleDataCons (DataTyCon cs _) = cs -visibleDataCons (NewTyCon c _ _) = [c] +visibleDataCons AbstractTyCon = [] +visibleDataCons (DataTyCon _ cs _) = cs +visibleDataCons (NewTyCon c _ _) = [c] \end{code} %************************************************************************ @@ -251,36 +266,34 @@ mkFunTyCon name kind -- This is the making of a TyCon. Just the same as the old mkAlgTyCon, -- but now you also have to pass in the generic information about the type -- constructor - you can get hold of it easily (see Generics module) -mkAlgTyCon name kind tyvars theta argvrcs rhs sels is_rec gen_info +mkAlgTyCon name kind tyvars argvrcs rhs flds is_rec gen_info = AlgTyCon { - tyConName = name, - tyConUnique = nameUnique name, - tyConKind = kind, - tyConArity = length tyvars, - tyConTyVars = tyvars, - argVrcs = argvrcs, - algTyConTheta = theta, - algRhs = rhs, - selIds = sels, - algTyConClass = Nothing, - algTyConRec = is_rec, - hasGenerics = gen_info + tyConName = name, + tyConUnique = nameUnique name, + tyConKind = kind, + tyConArity = length tyvars, + tyConTyVars = tyvars, + argVrcs = argvrcs, + algTcRhs = rhs, + algTcFields = flds, + algTcClass = Nothing, + algTcRec = is_rec, + hasGenerics = gen_info } mkClassTyCon name kind tyvars argvrcs rhs clas is_rec = AlgTyCon { - tyConName = name, - tyConUnique = nameUnique name, - tyConKind = kind, - tyConArity = length tyvars, - tyConTyVars = tyvars, - argVrcs = argvrcs, - algTyConTheta = [], - algRhs = rhs, - selIds = [], - algTyConClass = Just clas, - algTyConRec = is_rec, - hasGenerics = False + tyConName = name, + tyConUnique = nameUnique name, + tyConKind = kind, + tyConArity = length tyvars, + tyConTyVars = tyvars, + argVrcs = argvrcs, + algTcRhs = rhs, + algTcFields = [], + algTcClass = Just clas, + algTcRec = is_rec, + hasGenerics = False } @@ -351,7 +364,7 @@ isFunTyCon (FunTyCon {}) = True isFunTyCon _ = False isAbstractTyCon :: TyCon -> Bool -isAbstractTyCon (AlgTyCon { algRhs = AbstractTyCon }) = True +isAbstractTyCon (AlgTyCon { algTcRhs = AbstractTyCon }) = True isAbstractTyCon _ = False isPrimTyCon :: TyCon -> Bool @@ -369,10 +382,6 @@ isAlgTyCon (AlgTyCon {}) = True isAlgTyCon (TupleTyCon {}) = True isAlgTyCon other = False -algTyConRhs :: TyCon -> AlgTyConRhs -algTyConRhs (AlgTyCon {algRhs = rhs}) = rhs -algTyConRhs (TupleTyCon {dataCon = dc}) = DataTyCon [dc] False - isDataTyCon :: TyCon -> Bool -- isDataTyCon returns True for data types that are represented by -- heap-allocated constructors. @@ -381,18 +390,18 @@ isDataTyCon :: TyCon -> Bool -- True for all @data@ types -- False for newtypes -- unboxed tuples -isDataTyCon (AlgTyCon {algRhs = rhs}) +isDataTyCon (AlgTyCon {algTcRhs = rhs}) = case rhs of - DataTyCon _ _ -> True - NewTyCon _ _ _ -> False - AbstractTyCon -> panic "isDataTyCon" + DataTyCon _ _ _ -> True + NewTyCon _ _ _ -> False + AbstractTyCon -> panic "isDataTyCon" isDataTyCon (TupleTyCon {tyConBoxed = boxity}) = isBoxed boxity isDataTyCon other = False isNewTyCon :: TyCon -> Bool -isNewTyCon (AlgTyCon {algRhs = NewTyCon _ _ _}) = True -isNewTyCon other = False +isNewTyCon (AlgTyCon {algTcRhs = NewTyCon _ _ _}) = True +isNewTyCon other = False isProductTyCon :: TyCon -> Bool -- A "product" tycon @@ -402,10 +411,10 @@ isProductTyCon :: TyCon -> Bool -- may be DataType or NewType, -- may be unboxed or not, -- may be recursive or not -isProductTyCon tc@(AlgTyCon {}) = case algRhs tc of - DataTyCon [data_con] _ -> not (isExistentialDataCon data_con) - NewTyCon _ _ _ -> True - other -> False +isProductTyCon tc@(AlgTyCon {}) = case algTcRhs tc of + DataTyCon _ [data_con] _ -> isVanillaDataCon data_con + NewTyCon _ _ _ -> True + other -> False isProductTyCon (TupleTyCon {}) = True isProductTyCon other = False @@ -414,8 +423,8 @@ isSynTyCon (SynTyCon {}) = True isSynTyCon _ = False isEnumerationTyCon :: TyCon -> Bool -isEnumerationTyCon (AlgTyCon {algRhs = DataTyCon _ is_enum}) = is_enum -isEnumerationTyCon other = False +isEnumerationTyCon (AlgTyCon {algTcRhs = DataTyCon _ _ is_enum}) = is_enum +isEnumerationTyCon other = False isTupleTyCon :: TyCon -> Bool -- The unit tycon didn't used to be classed as a tuple tycon @@ -435,13 +444,13 @@ isBoxedTupleTyCon other = False tupleTyConBoxity tc = tyConBoxed tc isRecursiveTyCon :: TyCon -> Bool -isRecursiveTyCon (AlgTyCon {algTyConRec = Recursive}) = True +isRecursiveTyCon (AlgTyCon {algTcRec = Recursive}) = True isRecursiveTyCon other = False isHiBootTyCon :: TyCon -> Bool -- Used for knot-tying in hi-boot files -isHiBootTyCon (AlgTyCon {algRhs = AbstractTyCon}) = True -isHiBootTyCon other = False +isHiBootTyCon (AlgTyCon {algTcRhs = AbstractTyCon}) = True +isHiBootTyCon other = False isForeignTyCon :: TyCon -> Bool -- isForeignTyCon identifies foreign-imported type constructors @@ -461,42 +470,44 @@ tyConDataCons :: TyCon -> [DataCon] tyConDataCons tycon = tyConDataCons_maybe tycon `orElse` [] tyConDataCons_maybe :: TyCon -> Maybe [DataCon] -tyConDataCons_maybe (AlgTyCon {algRhs = DataTyCon cons _}) = Just cons -tyConDataCons_maybe (AlgTyCon {algRhs = NewTyCon con _ _}) = Just [con] -tyConDataCons_maybe (TupleTyCon {dataCon = con}) = Just [con] -tyConDataCons_maybe other = Nothing +tyConDataCons_maybe (AlgTyCon {algTcRhs = DataTyCon _ cons _}) = Just cons +tyConDataCons_maybe (AlgTyCon {algTcRhs = NewTyCon con _ _}) = Just [con] +tyConDataCons_maybe (TupleTyCon {dataCon = con}) = Just [con] +tyConDataCons_maybe other = Nothing tyConFamilySize :: TyCon -> Int -tyConFamilySize (AlgTyCon {algRhs = DataTyCon cons _}) = length cons -tyConFamilySize (AlgTyCon {algRhs = NewTyCon _ _ _}) = 1 -tyConFamilySize (TupleTyCon {}) = 1 +tyConFamilySize (AlgTyCon {algTcRhs = DataTyCon _ cons _}) = length cons +tyConFamilySize (AlgTyCon {algTcRhs = NewTyCon _ _ _}) = 1 +tyConFamilySize (TupleTyCon {}) = 1 #ifdef DEBUG tyConFamilySize other = pprPanic "tyConFamilySize:" (ppr other) #endif +tyConFields :: TyCon -> [(FieldLabel,Type,Id)] +tyConFields (AlgTyCon {algTcFields = fs}) = fs +tyConFields other_tycon = [] + tyConSelIds :: TyCon -> [Id] -tyConSelIds (AlgTyCon {selIds = sels}) = sels -tyConSelIds other_tycon = [] +tyConSelIds tc = [id | (_,_,id) <- tyConFields tc] \end{code} \begin{code} newTyConRep :: TyCon -> ([TyVar], Type) -newTyConRep (AlgTyCon {tyConTyVars = tvs, algRhs = NewTyCon _ _ rep}) = (tvs, rep) +newTyConRep (AlgTyCon {tyConTyVars = tvs, algTcRhs = NewTyCon _ _ rep}) = (tvs, rep) newTyConRhs :: TyCon -> ([TyVar], Type) -newTyConRhs (AlgTyCon {tyConTyVars = tvs, algRhs = NewTyCon _ rhs _}) = (tvs, rhs) -\end{code} +newTyConRhs (AlgTyCon {tyConTyVars = tvs, algTcRhs = NewTyCon _ rhs _}) = (tvs, rhs) -\begin{code} tyConPrimRep :: TyCon -> PrimRep tyConPrimRep (PrimTyCon {primTyConRep = rep}) = rep tyConPrimRep tc = ASSERT(not (isUnboxedTupleTyCon tc)) PtrRep \end{code} \begin{code} -tyConTheta :: TyCon -> [PredType] -tyConTheta (AlgTyCon {algTyConTheta = theta}) = theta -tyConTheta (TupleTyCon {}) = [] +tyConStupidTheta :: TyCon -> [PredType] +tyConStupidTheta (AlgTyCon {algTcRhs = DataTyCon mb_th _ _}) = mb_th `orElse` [] +tyConStupidTheta (AlgTyCon {algTcRhs = other}) = [] +tyConStupidTheta (TupleTyCon {}) = [] -- shouldn't ask about anything else \end{code} @@ -520,22 +531,22 @@ getSynTyConDefn (SynTyCon {tyConTyVars = tyvars, synTyConDefn = ty}) = (tyvars,t \begin{code} maybeTyConSingleCon :: TyCon -> Maybe DataCon -maybeTyConSingleCon (AlgTyCon {algRhs = DataTyCon [c] _}) = Just c -maybeTyConSingleCon (AlgTyCon {algRhs = NewTyCon c _ _}) = Just c -maybeTyConSingleCon (AlgTyCon {}) = Nothing -maybeTyConSingleCon (TupleTyCon {dataCon = con}) = Just con -maybeTyConSingleCon (PrimTyCon {}) = Nothing -maybeTyConSingleCon (FunTyCon {}) = Nothing -- case at funty +maybeTyConSingleCon (AlgTyCon {algTcRhs = DataTyCon _ [c] _}) = Just c +maybeTyConSingleCon (AlgTyCon {algTcRhs = NewTyCon c _ _}) = Just c +maybeTyConSingleCon (AlgTyCon {}) = Nothing +maybeTyConSingleCon (TupleTyCon {dataCon = con}) = Just con +maybeTyConSingleCon (PrimTyCon {}) = Nothing +maybeTyConSingleCon (FunTyCon {}) = Nothing -- case at funty maybeTyConSingleCon tc = pprPanic "maybeTyConSingleCon: unexpected tycon " $ ppr tc \end{code} \begin{code} isClassTyCon :: TyCon -> Bool -isClassTyCon (AlgTyCon {algTyConClass = Just _}) = True +isClassTyCon (AlgTyCon {algTcClass = Just _}) = True isClassTyCon other_tycon = False tyConClass_maybe :: TyCon -> Maybe Class -tyConClass_maybe (AlgTyCon {algTyConClass = maybe_clas}) = maybe_clas +tyConClass_maybe (AlgTyCon {algTcClass = maybe_clas}) = maybe_clas tyConClass_maybe ther_tycon = Nothing \end{code} diff --git a/ghc/compiler/types/Type.lhs b/ghc/compiler/types/Type.lhs index c7e5fa2509..ab9f4519e5 100644 --- a/ghc/compiler/types/Type.lhs +++ b/ghc/compiler/types/Type.lhs @@ -6,7 +6,7 @@ \begin{code} module Type ( -- re-exports from TypeRep - TyThing(..), Type, PredType(..), ThetaType, TyVarSubst, + TyThing(..), Type, PredType(..), ThetaType, funTyCon, -- Re-exports from Kind @@ -19,7 +19,8 @@ module Type ( mkAppTy, mkAppTys, splitAppTy, splitAppTys, splitAppTy_maybe, - mkFunTy, mkFunTys, splitFunTy, splitFunTy_maybe, splitFunTys, + mkFunTy, mkFunTys, splitFunTy, splitFunTy_maybe, + splitFunTys, splitFunTysN, funResultTy, funArgTy, zipFunTys, isFunTy, mkGenTyConApp, mkTyConApp, mkTyConTy, @@ -34,7 +35,7 @@ module Type ( applyTy, applyTys, isForAllTy, dropForAlls, -- Source types - predTypeRep, mkPredTy, mkPredTys, + predTypeRep, newTypeRep, mkPredTy, mkPredTys, -- Newtypes splitRecNewType_maybe, @@ -60,6 +61,17 @@ module Type ( -- Seq seqType, seqTypes, + -- Type substitutions + TvSubst(..), -- Representation visible to a few friends + TvSubstEnv, emptyTvSubst, + mkTvSubst, zipTvSubst, zipTopTvSubst, mkTopTvSubst, + getTvSubstEnv, setTvSubstEnv, getTvInScope, extendTvInScope, + extendTvSubst, extendTvSubstList, isInScope, + + -- Performing substitution on types + substTy, substTys, substTyWith, substTheta, substTyVar, + deShadowTy, + -- Pretty-printing pprType, pprParendType, pprPred, pprTheta, pprThetaArrow, pprClassPred @@ -72,13 +84,9 @@ module Type ( import TypeRep --- Other imports: - -import {-# SOURCE #-} Subst ( substTyWith ) - -- friends: import Kind -import Var ( TyVar, tyVarKind, tyVarName, setTyVarName ) +import Var ( Var, TyVar, tyVarKind, tyVarName, setTyVarName ) import VarEnv import VarSet @@ -246,6 +254,13 @@ splitFunTys ty = split [] ty ty split args orig_ty (NewTcApp tc tys) = split args orig_ty (newTypeRep tc tys) split args orig_ty ty = (reverse args, orig_ty) +splitFunTysN :: Int -> Type -> ([Type], Type) +-- Split off exactly n arg tys +splitFunTysN 0 ty = ([], ty) +splitFunTysN n ty = case splitFunTy ty of { (arg, res) -> + case splitFunTysN (n-1) res of { (args, res) -> + (arg:args, res) }} + zipFunTys :: Outputable a => [a] -> Type -> ([(a,Type)], Type) zipFunTys orig_xs orig_ty = split [] orig_xs orig_ty orig_ty where @@ -918,3 +933,209 @@ eq_tys env (t1:tys1) (t2:tys2) = (eq_ty env t1 t2) && (eq_tys env tys1 tys2) eq_tys env tys1 tys2 = False \end{code} + +%************************************************************************ +%* * + Type substitutions +%* * +%************************************************************************ + +\begin{code} +data TvSubst + = TvSubst InScopeSet -- The in-scope type variables + TvSubstEnv -- The substitution itself; guaranteed idempotent + -- See Note [Apply Once] + +{- ---------------------------------------------------------- + Note [Apply Once] + +We use TvSubsts to instantiate things, and we might instantiate + forall a b. ty +\with the types + [a, b], or [b, a]. +So the substition might go [a->b, b->a]. A similar situation arises in Core +when we find a beta redex like + (/\ a /\ b -> e) b a +Then we also end up with a substition that permutes type variables. Other +variations happen to; for example [a -> (a, b)]. + + *************************************************** + *** So a TvSubst must be applied precisely once *** + *************************************************** + +A TvSubst is not idempotent, but, unlike the non-idempotent substitution +we use during unifications, it must not be repeatedly applied. +-------------------------------------------------------------- -} + + +type TvSubstEnv = TyVarEnv Type + -- A TvSubstEnv is used both inside a TvSubst (with the apply-once + -- invariant discussed in Note [Apply Once]), and also independently + -- in the middle of matching, and unification (see Types.Unify) + -- So you have to look at the context to know if it's idempotent or + -- apply-once or whatever + +emptyTvSubst = TvSubst emptyInScopeSet emptyVarEnv +isEmptyTvSubst :: TvSubst -> Bool +isEmptyTvSubst (TvSubst _ env) = isEmptyVarEnv env + +getTvSubstEnv :: TvSubst -> TvSubstEnv +getTvSubstEnv (TvSubst _ env) = env + +getTvInScope :: TvSubst -> InScopeSet +getTvInScope (TvSubst in_scope _) = in_scope + +isInScope :: Var -> TvSubst -> Bool +isInScope v (TvSubst in_scope _) = v `elemInScopeSet` in_scope + +setTvSubstEnv :: TvSubst -> TvSubstEnv -> TvSubst +setTvSubstEnv (TvSubst in_scope _) env = TvSubst in_scope env + +extendTvInScope :: TvSubst -> [Var] -> TvSubst +extendTvInScope (TvSubst in_scope env) vars = TvSubst (extendInScopeSetList in_scope vars) env + +extendTvSubst :: TvSubst -> TyVar -> Type -> TvSubst +extendTvSubst (TvSubst in_scope env) tv ty = TvSubst in_scope (extendVarEnv env tv ty) + +extendTvSubstList :: TvSubst -> [TyVar] -> [Type] -> TvSubst +extendTvSubstList (TvSubst in_scope env) tvs tys + = TvSubst in_scope (extendVarEnvList env (tvs `zip` tys)) + +-- mkTvSubst and zipTvSubst generate the in-scope set from +-- the types given; but it's just a thunk so with a bit of luck +-- it'll never be evaluated + +mkTvSubst :: TvSubstEnv -> TvSubst +mkTvSubst env + = TvSubst (mkInScopeSet (tyVarsOfTypes (varEnvElts env))) env + +zipTvSubst :: [TyVar] -> [Type] -> TvSubst +zipTvSubst tyvars tys + = TvSubst (mkInScopeSet (tyVarsOfTypes tys)) (zipTyEnv tyvars tys) + +-- mkTopTvSubst is called when doing top-level substitutions. +-- Here we expect that the free vars of the range of the +-- substitution will be empty. +mkTopTvSubst :: [(TyVar, Type)] -> TvSubst +mkTopTvSubst prs = TvSubst emptyInScopeSet (mkVarEnv prs) + +zipTopTvSubst :: [TyVar] -> [Type] -> TvSubst +zipTopTvSubst tyvars tys = TvSubst emptyInScopeSet (zipTyEnv tyvars tys) + +zipTyEnv :: [TyVar] -> [Type] -> TvSubstEnv +zipTyEnv tyvars tys +#ifdef DEBUG + | length tyvars /= length tys + = pprTrace "mkTopTvSubst" (ppr tyvars $$ ppr tys) emptyVarEnv + | otherwise +#endif + = zip_ty_env tyvars tys emptyVarEnv + +-- Later substitutions in the list over-ride earlier ones, +-- but there should be no loops +zip_ty_env [] [] env = env +zip_ty_env (tv:tvs) (ty:tys) env = zip_ty_env tvs tys (extendVarEnv env tv ty) + -- There used to be a special case for when + -- ty == TyVarTy tv + -- (a not-uncommon case) in which case the substitution was dropped. + -- But the type-tidier changes the print-name of a type variable without + -- changing the unique, and that led to a bug. Why? Pre-tidying, we had + -- a type {Foo t}, where Foo is a one-method class. So Foo is really a newtype. + -- And it happened that t was the type variable of the class. Post-tiding, + -- it got turned into {Foo t2}. The ext-core printer expanded this using + -- sourceTypeRep, but that said "Oh, t == t2" because they have the same unique, + -- and so generated a rep type mentioning t not t2. + -- + -- Simplest fix is to nuke the "optimisation" + +instance Outputable TvSubst where + ppr (TvSubst ins env) + = sep[ ptext SLIT("<TvSubst"), + nest 2 (ptext SLIT("In scope:") <+> ppr ins), + nest 2 (ptext SLIT("Env:") <+> ppr env) ] +\end{code} + +%************************************************************************ +%* * + Performing type substitutions +%* * +%************************************************************************ + +\begin{code} +substTyWith :: [TyVar] -> [Type] -> Type -> Type +substTyWith tvs tys = substTy (zipTvSubst tvs tys) + +substTy :: TvSubst -> Type -> Type +substTy subst ty | isEmptyTvSubst subst = ty + | otherwise = subst_ty subst ty + +substTys :: TvSubst -> [Type] -> [Type] +substTys subst tys | isEmptyTvSubst subst = tys + | otherwise = map (subst_ty subst) tys + +deShadowTy :: Type -> Type -- Remove any shadowing from the type +deShadowTy ty = subst_ty emptyTvSubst ty + +substTheta :: TvSubst -> ThetaType -> ThetaType +substTheta subst theta + | isEmptyTvSubst subst = theta + | otherwise = map (substPred subst) theta + +substPred :: TvSubst -> PredType -> PredType +substPred subst (IParam n ty) = IParam n (subst_ty subst ty) +substPred subst (ClassP clas tys) = ClassP clas (map (subst_ty subst) tys) + +-- Note that the in_scope set is poked only if we hit a forall +-- so it may often never be fully computed +subst_ty subst@(TvSubst in_scope env) ty + = go ty + where + go ty@(TyVarTy tv) = case (lookupVarEnv env tv) of + Nothing -> ty + Just ty' -> ty' -- See Note [Apply Once] + + go (TyConApp tc tys) = let args = map go tys + in args `seqList` TyConApp tc args + + go (NewTcApp tc tys) = let args = map go tys + in args `seqList` NewTcApp tc args + + go (PredTy p) = PredTy $! (substPred subst p) + + go (NoteTy (SynNote ty1) ty2) = NoteTy (SynNote $! (go ty1)) $! (go ty2) + go (NoteTy (FTVNote _) ty2) = go ty2 -- Discard the free tyvar note + + go (FunTy arg res) = (FunTy $! (go arg)) $! (go res) + go (AppTy fun arg) = mkAppTy (go fun) $! (go arg) + -- The mkAppTy smart constructor is important + -- we might be replacing (a Int), represented with App + -- by [Int], represented with TyConApp + go (ForAllTy tv ty) = case substTyVar subst tv of + (subst', tv') -> ForAllTy tv' $! (subst_ty subst' ty) + +substTyVar :: TvSubst -> TyVar -> (TvSubst, TyVar) +substTyVar subst@(TvSubst in_scope env) old_var + | old_var == new_var -- No need to clone + -- But we *must* zap any current substitution for the variable. + -- For example: + -- (\x.e) with id_subst = [x |-> e'] + -- Here we must simply zap the substitution for x + -- + -- The new_id isn't cloned, but it may have a different type + -- etc, so we must return it, not the old id + = (TvSubst (in_scope `extendInScopeSet` new_var) (delVarEnv env old_var), + new_var) + + | otherwise -- The new binder is in scope so + -- we'd better rename it away from the in-scope variables + -- Extending the substitution to do this renaming also + -- has the (correct) effect of discarding any existing + -- substitution for that variable + = (TvSubst (in_scope `extendInScopeSet` new_var) (extendVarEnv env old_var (TyVarTy new_var)), + new_var) + where + new_var = uniqAway in_scope old_var + -- The uniqAway part makes sure the new variable is not already in scope +\end{code} + + diff --git a/ghc/compiler/types/TypeRep.lhs b/ghc/compiler/types/TypeRep.lhs index a867cad601..287c2be5c5 100644 --- a/ghc/compiler/types/TypeRep.lhs +++ b/ghc/compiler/types/TypeRep.lhs @@ -10,7 +10,6 @@ module TypeRep ( PredType(..), -- to friends Kind, ThetaType, -- Synonyms - TyVarSubst, funTyCon, @@ -31,8 +30,7 @@ import {-# SOURCE #-} DataCon( DataCon, dataConName ) -- friends: import Kind -import Var ( Id, TyVar, tyVarKind ) -import VarEnv ( TyVarEnv ) +import Var ( Var, Id, TyVar, tyVarKind ) import VarSet ( TyVarSet ) import Name ( Name, NamedThing(..), BuiltInSyntax(..), mkWiredInName ) import OccName ( mkOccFS, tcName ) @@ -41,7 +39,7 @@ import TyCon ( TyCon, mkFunTyCon, tyConArity, tupleTyConBoxity, isTupleTyCon, import Class ( Class ) -- others -import PrelNames ( gHC_PRIM, funTyConKey, listTyConKey, parrTyConKey, hasKey ) +import PrelNames ( gHC_PRIM, funTyConKey, listTyConKey, parrTyConKey, hasKey ) import Outputable \end{code} @@ -146,14 +144,13 @@ to cut all loops. The other members of the loop may be marked 'non-recursive'. \begin{code} -type TyVarSubst = TyVarEnv Type - data Type = TyVarTy TyVar | AppTy - Type -- Function is *not* a TyConApp - Type + Type -- Function is *not* a TyConApp or NewTcApp + Type -- It must be another AppTy, or TyVarTy + -- (or NoteTy of these) | TyConApp -- Application of a TyCon TyCon -- *Invariant* saturated appliations of FunTyCon and diff --git a/ghc/compiler/types/Unify.lhs b/ghc/compiler/types/Unify.lhs new file mode 100644 index 0000000000..42ea928ea5 --- /dev/null +++ b/ghc/compiler/types/Unify.lhs @@ -0,0 +1,405 @@ +\begin{code} +module Unify ( + -- Matching and unification + matchTys, matchTyX, matchTysX, + unifyTys, unifyTysX, + + tcRefineTys, tcMatchTys, tcMatchPreds, coreRefineTys, + + -- Re-export + MaybeErr(..) + ) where + +#include "HsVersions.h" + +import Var ( Var, TyVar, tyVarKind ) +import VarEnv +import VarSet +import Kind ( isSubKind ) +import Type ( predTypeRep, newTypeRep, typeKind, + tyVarsOfType, tyVarsOfTypes, + TvSubstEnv, TvSubst(..), substTy ) +import TypeRep ( Type(..), PredType(..), funTyCon ) +import Util ( snocView ) +import ErrUtils ( Message ) +import Outputable +import Maybes +\end{code} + + +%************************************************************************ +%* * + External interface +%* * +%************************************************************************ + +\begin{code} +---------------------------- +tcRefineTys, tcMatchTys + :: [TyVar] -- Try to unify these + -> TvSubstEnv -- Not idempotent + -> [Type] -> [Type] + -> MaybeErr TvSubstEnv Message -- Not idempotent +-- This one is used by the type checker. Neither the input nor result +-- substitition is idempotent +tcRefineTys ex_tvs subst tys1 tys2 + = initUM (tryToBind (mkVarSet ex_tvs)) (unify_tys Src subst tys1 tys2) + +tcMatchTys ex_tvs subst tys1 tys2 + = initUM (bindOnly (mkVarSet ex_tvs)) (unify_tys Src subst tys1 tys2) + +tcMatchPreds + :: [TyVar] -- Bind these + -> [PredType] -> [PredType] + -> Maybe TvSubstEnv +tcMatchPreds tvs preds1 preds2 + = maybeErrToMaybe $ initUM (bindOnly (mkVarSet tvs)) $ + unify_preds Src emptyVarEnv preds1 preds2 + +---------------------------- +coreRefineTys :: [TyVar] -- Try to unify these + -> TvSubst -- A full-blown apply-once substitition + -> Type -- A fixed point of the incoming substitution + -> Type + -> Maybe TvSubstEnv -- In-scope set is unaffected +-- Used by Core Lint and the simplifier. Takes a full apply-once substitution. +-- The incoming substitution's in-scope set should mention all the variables free +-- in the incoming types +coreRefineTys ex_tvs subst@(TvSubst in_scope orig_env) ty1 ty2 + = maybeErrToMaybe $ initUM (tryToBind (mkVarSet ex_tvs)) $ + do { -- Apply the input substitution; nothing int ty2 + let ty1' = substTy subst ty1 + -- Run the unifier, starting with an empty env + ; extra_env <- unify Src emptyTvSubstEnv ty1' ty2 + + -- Find the fixed point of the resulting non-idempotent + -- substitution, and apply it to the + ; let extra_subst = TvSubst in_scope extra_env_fixpt + extra_env_fixpt = mapVarEnv (substTy extra_subst) extra_env + orig_env' = mapVarEnv (substTy extra_subst) orig_env + ; return (orig_env' `plusVarEnv` extra_env_fixpt) } + + +---------------------------- +matchTys :: TyVarSet -- Template tyvars + -> [Type] -- Template + -> [Type] -- Target + -> Maybe TvSubstEnv -- Idempotent, because when matching + -- the range and domain are distinct + +-- PRE-CONDITION for matching: template variables are not free in the target + +matchTys tmpls tys1 tys2 + = ASSERT2( not (intersectsVarSet tmpls (tyVarsOfTypes tys2)), + ppr tmpls $$ ppr tys1 $$ ppr tys2 ) + maybeErrToMaybe $ initUM (bindOnly tmpls) + (unify_tys Src emptyTvSubstEnv tys1 tys2) + +matchTyX :: TyVarSet -- Template tyvars + -> TvSubstEnv -- Idempotent substitution to extend + -> Type -- Template + -> Type -- Target + -> Maybe TvSubstEnv -- Idempotent + +matchTyX tmpls env ty1 ty2 + = ASSERT( not (intersectsVarSet tmpls (tyVarsOfType ty2)) ) + maybeErrToMaybe $ initUM (bindOnly tmpls) + (unify Src env ty1 ty2) + +matchTysX :: TyVarSet -- Template tyvars + -> TvSubstEnv -- Idempotent substitution to extend + -> [Type] -- Template + -> [Type] -- Target + -> Maybe TvSubstEnv -- Idempotent + +matchTysX tmpls env tys1 tys2 + = ASSERT( not (intersectsVarSet tmpls (tyVarsOfTypes tys2)) ) + maybeErrToMaybe $ initUM (bindOnly tmpls) + (unify_tys Src env tys1 tys2) + + +---------------------------- +unifyTys :: TyVarSet -> [Type] -> [Type] -> Maybe TvSubstEnv +unifyTys bind_these tys1 tys2 + = maybeErrToMaybe $ initUM (bindOnly bind_these) $ + unify_tys Src emptyTvSubstEnv tys1 tys2 + +unifyTysX :: TyVarSet -> TvSubstEnv -> [Type] -> [Type] -> Maybe TvSubstEnv +unifyTysX bind_these subst tys1 tys2 + = maybeErrToMaybe $ initUM (bindOnly bind_these) $ + unify_tys Src subst tys1 tys2 + +---------------------------- +tryToBind, bindOnly :: TyVarSet -> TyVar -> BindFlag +tryToBind tv_set tv | tv `elemVarSet` tv_set = BindMe + | otherwise = AvoidMe + +bindOnly tv_set tv | tv `elemVarSet` tv_set = BindMe + | otherwise = DontBindMe + +emptyTvSubstEnv :: TvSubstEnv +emptyTvSubstEnv = emptyVarEnv +\end{code} + + +%************************************************************************ +%* * + The workhorse +%* * +%************************************************************************ + +\begin{code} +unify :: SrcFlag -- True, unifying source types, false core types. + -> TvSubstEnv -- An existing substitution to extend + -> Type -> Type -- Types to be unified + -> UM TvSubstEnv -- Just the extended substitution, + -- Nothing if unification failed +-- We do not require the incoming substitution to be idempotent, +-- nor guarantee that the outgoing one is. That's fixed up by +-- the wrappers. + +-- ToDo: remove debugging junk +unify s subst ty1 ty2 = -- pprTrace "unify" (ppr subst <+> pprParendType ty1 <+> pprParendType ty2) $ + unify_ s subst ty1 ty2 + +-- Look through NoteTy in the obvious fashion +unify_ s subst (NoteTy _ ty1) ty2 = unify s subst ty1 ty2 +unify_ s subst ty1 (NoteTy _ ty2) = unify s subst ty1 ty2 + +-- In Core mode, look through NewTcApps and Preds +unify_ Core subst (NewTcApp tc tys) ty2 = unify Core subst (newTypeRep tc tys) ty2 +unify_ Core subst ty1 (NewTcApp tc tys) = unify Core subst ty1 (newTypeRep tc tys) + +unify_ Core subst (PredTy p) ty2 = unify Core subst (predTypeRep p) ty2 +unify_ Core subst ty1 (PredTy p) = unify Core subst ty1 (predTypeRep p) + +-- From now on, any NewTcApps/Preds should be taken at face value + +unify_ s subst (TyVarTy tv1) ty2 = uVar s False subst tv1 ty2 +unify_ s subst ty1 (TyVarTy tv2) = uVar s True subst tv2 ty1 + +unify_ s subst (PredTy p1) (PredTy p2) = unify_pred s subst p1 p2 + +unify_ s subst t1@(TyConApp tyc1 tys1) t2@(TyConApp tyc2 tys2) + | tyc1 == tyc2 = unify_tys s subst tys1 tys2 +unify_ Src subst t1@(NewTcApp tc1 tys1) t2@(NewTcApp tc2 tys2) + | tc1 == tc2 = unify_tys Src subst tys1 tys2 +unify_ s subst (FunTy ty1a ty1b) (FunTy ty2a ty2b) + = do { subst' <- unify s subst ty1a ty2a + ; unify s subst' ty1b ty2b } + + -- Applications need a bit of care! + -- They can match FunTy and TyConApp, so use splitAppTy_maybe + -- NB: we've already dealt with type variables and Notes, + -- so if one type is an App the other one jolly well better be too +unify_ s subst (AppTy ty1a ty1b) ty2 + | Just (ty2a, ty2b) <- unifySplitAppTy_maybe ty2 + = do { subst' <- unify s subst ty1a ty2a + ; unify s subst' ty1b ty2b } + +unify_ s subst ty1 (AppTy ty2a ty2b) + | Just (ty1a, ty1b) <- unifySplitAppTy_maybe ty1 + = do { subst' <- unify s subst ty1a ty2a + ; unify s subst' ty1b ty2b } + +unify_ s subst ty1 ty2 = failWith (misMatch ty1 ty2) + +------------------------------ +unify_pred s subst (ClassP c1 tys1) (ClassP c2 tys2) + | c1 == c2 = unify_tys s subst tys1 tys2 +unify_pred s subst (IParam n1 t1) (IParam n2 t2) + | n1 == n2 = unify s subst t1 t2 + +------------------------------ +unifySplitAppTy_maybe :: Type -> Maybe (Type,Type) +-- NoteTy is already dealt with; take NewTcApps at face value +unifySplitAppTy_maybe (FunTy ty1 ty2) = Just (TyConApp funTyCon [ty1], ty2) +unifySplitAppTy_maybe (AppTy ty1 ty2) = Just (ty1, ty2) +unifySplitAppTy_maybe (TyConApp tc tys) = case snocView tys of + Just (tys', ty') -> Just (TyConApp tc tys', ty') + Nothing -> Nothing +unifySplitAppTy_maybe (NewTcApp tc tys) = case snocView tys of + Just (tys', ty') -> Just (NewTcApp tc tys', ty') + Nothing -> Nothing +unifySplitAppTy_maybe other = Nothing + +------------------------------ +unify_tys s = unifyList (unify s) + +unify_preds :: SrcFlag -> TvSubstEnv -> [PredType] -> [PredType] -> UM TvSubstEnv +unify_preds s = unifyList (unify_pred s) + +unifyList :: Outputable a + => (TvSubstEnv -> a -> a -> UM TvSubstEnv) + -> TvSubstEnv -> [a] -> [a] -> UM TvSubstEnv +unifyList unifier subst orig_xs orig_ys + = go subst orig_xs orig_ys + where + go subst [] [] = return subst + go subst (x:xs) (y:ys) = do { subst' <- unifier subst x y + ; go subst' xs ys } + go subst _ _ = failWith (lengthMisMatch orig_xs orig_ys) + +------------------------------ +uVar :: SrcFlag -- True, unifying source types, false core types. + -> Bool -- Swapped + -> TvSubstEnv -- An existing substitution to extend + -> TyVar -- Type variable to be unified + -> Type -- with this type + -> UM TvSubstEnv + +uVar s swap subst tv1 ty + = -- check to see whether tv1 is refined + case (lookupVarEnv subst tv1) of + -- yes, call back into unify' + Just ty' | swap -> unify s subst ty ty' + | otherwise -> unify s subst ty' ty + -- No, continue + Nothing -> uUnrefined subst tv1 ty + + +uUnrefined :: TvSubstEnv -- An existing substitution to extend + -> TyVar -- Type variable to be unified + -> Type -- with this type + -> UM TvSubstEnv + +-- We know that tv1 isn't refined +uUnrefined subst tv1 ty2@(TyVarTy tv2) + | tv1 == tv2 -- Same, do nothing + = return subst + + -- Check to see whether tv2 is refined + | Just ty' <- lookupVarEnv subst tv2 + = uUnrefined subst tv1 ty' + + -- So both are unrefined; next, see if the kinds force the direction + | k1 == k2 -- Can update either; so check the bind-flags + = do { b1 <- tvBindFlag tv1 + ; b2 <- tvBindFlag tv2 + ; case (b1,b2) of + (DontBindMe, DontBindMe) -> failWith (misMatch ty1 ty2) + (DontBindMe, _) -> bindTv subst tv2 ty1 + (BindMe, _) -> bindTv subst tv1 ty2 + (AvoidMe, BindMe) -> bindTv subst tv2 ty1 + (AvoidMe, _) -> bindTv subst tv1 ty2 + } + + | k1 `isSubKind` k2 -- Must update tv2 + = do { b2 <- tvBindFlag tv2 + ; case b2 of + DontBindMe -> failWith (misMatch ty1 ty2) + other -> bindTv subst tv2 ty1 + } + + | k2 `isSubKind` k1 -- Must update tv1 + = do { b1 <- tvBindFlag tv1 + ; case b1 of + DontBindMe -> failWith (misMatch ty1 ty2) + other -> bindTv subst tv1 ty2 + } + + | otherwise = failWith (kindMisMatch tv1 ty2) + where + ty1 = TyVarTy tv1 + k1 = tyVarKind tv1 + k2 = tyVarKind tv2 + +uUnrefined subst tv1 ty2 -- ty2 is not a type variable + -- Do occurs check... + | tv1 `elemVarSet` substTvSet subst (tyVarsOfType ty2) + = failWith (occursCheck tv1 ty2) + -- And a kind check... + | k2 `isSubKind` k1 + = do { b1 <- tvBindFlag tv1 + ; case b1 of -- And check that tv1 is bindable + DontBindMe -> failWith (misMatch ty1 ty2) + other -> bindTv subst tv1 ty2 + } + | otherwise + = pprTrace "kind" (ppr tv1 <+> ppr k1 $$ ppr ty2 <+> ppr k2) $ + failWith (kindMisMatch tv1 ty2) + where + ty1 = TyVarTy tv1 + k1 = tyVarKind tv1 + k2 = typeKind ty2 + +substTvSet :: TvSubstEnv -> TyVarSet -> TyVarSet +-- Apply the non-idempotent substitution to a set of type variables, +-- remembering that the substitution isn't necessarily idempotent +substTvSet subst tvs + = foldVarSet (unionVarSet . get) emptyVarSet tvs + where + get tv = case lookupVarEnv subst tv of + Nothing -> unitVarSet tv + Just ty -> substTvSet subst (tyVarsOfType ty) + +bindTv subst tv ty = return (extendVarEnv subst tv ty) +\end{code} + +%************************************************************************ +%* * + Unification monad +%* * +%************************************************************************ + +\begin{code} +data SrcFlag = Src | Core -- Unifying at the source level, or core level? + +data BindFlag = BindMe | AvoidMe | DontBindMe + +isCore Core = True +isCore Src = False + +newtype UM a = UM { unUM :: (TyVar -> BindFlag) + -> MaybeErr a Message } + +instance Monad UM where + return a = UM (\tvs -> Succeeded a) + fail s = UM (\tvs -> Failed (text s)) + m >>= k = UM (\tvs -> case unUM m tvs of + Failed err -> Failed err + Succeeded v -> unUM (k v) tvs) + +initUM :: (TyVar -> BindFlag) -> UM a -> MaybeErr a Message +initUM badtvs um = unUM um badtvs + +tvBindFlag :: TyVar -> UM BindFlag +tvBindFlag tv = UM (\tv_fn -> Succeeded (tv_fn tv)) + +failWith :: Message -> UM a +failWith msg = UM (\tv_fn -> Failed msg) + +maybeErrToMaybe :: MaybeErr succ fail -> Maybe succ +maybeErrToMaybe (Succeeded a) = Just a +maybeErrToMaybe (Failed m) = Nothing +\end{code} + + +%************************************************************************ +%* * + Error reporting + We go to a lot more trouble to tidy the types + in TcUnify. Maybe we'll end up having to do that + here too, but I'll leave it for now. +%* * +%************************************************************************ + +\begin{code} +misMatch t1 t2 + = ptext SLIT("Can't match types") <+> quotes (ppr t1) <+> + ptext SLIT("and") <+> quotes (ppr t2) + +lengthMisMatch tys1 tys2 + = sep [ptext SLIT("Can't match unequal length lists"), + nest 2 (ppr tys1), nest 2 (ppr tys2) ] + +kindMisMatch tv1 t2 + = vcat [ptext SLIT("Can't match kinds") <+> quotes (ppr (tyVarKind tv1)) <+> + ptext SLIT("and") <+> quotes (ppr (typeKind t2)), + ptext SLIT("when matching") <+> quotes (ppr tv1) <+> + ptext SLIT("with") <+> quotes (ppr t2)] + +occursCheck tv ty + = hang (ptext SLIT("Can't construct the infinite type")) + 2 (ppr tv <+> equals <+> ppr ty) +\end{code}
\ No newline at end of file diff --git a/ghc/compiler/utils/Outputable.lhs b/ghc/compiler/utils/Outputable.lhs index 22856f1a28..8b52867677 100644 --- a/ghc/compiler/utils/Outputable.lhs +++ b/ghc/compiler/utils/Outputable.lhs @@ -42,10 +42,10 @@ module Outputable ( showSDocUnqual, showsPrecSDoc, pprHsChar, pprHsString, - -- error handling - pprPanic, pprPanic#, pprError, pprTrace, assertPprPanic, warnPprTrace, - trace, panic, panic#, assertPanic + pprPanic, assertPprPanic, pprPanic#, pprPgmError, + pprTrace, warnPprTrace, + trace, pgmError, panic, panic#, assertPanic ) where #include "HsVersions.h" @@ -470,12 +470,13 @@ speakNTimes t | t == 1 = ptext SLIT("once") %************************************************************************ \begin{code} -pprPanic :: String -> SDoc -> a -pprError :: String -> SDoc -> a +pprPanic, pprPgmError :: String -> SDoc -> a pprTrace :: String -> SDoc -> a -> a -pprPanic = pprAndThen panic -pprError = pprAndThen error -pprTrace = pprAndThen trace +pprPanic = pprAndThen panic -- Throw an exn saying "bug in GHC" + +pprPgmError = pprAndThen pgmError -- Throw an exn saying "bug in pgm being compiled" + -- (used for unusual pgm errors) +pprTrace = pprAndThen trace pprPanic# heading pretty_msg = panic# (show (doc PprDebug)) where diff --git a/ghc/compiler/utils/Panic.lhs b/ghc/compiler/utils/Panic.lhs index 2a5d3a4174..60393b581f 100644 --- a/ghc/compiler/utils/Panic.lhs +++ b/ghc/compiler/utils/Panic.lhs @@ -12,9 +12,10 @@ some unnecessary loops in the module dependency graph. module Panic ( GhcException(..), ghcError, progName, + pgmError, panic, panic#, assertPanic, trace, showException, showGhcException, tryMost, - installSignalHandlers, + installSignalHandlers, catchJust, tryJust, ioErrors, throwTo, ) where @@ -136,8 +137,9 @@ instance Typeable GhcException where Panics and asserts. \begin{code} -panic :: String -> a -panic x = Exception.throwDyn (Panic x) +panic, pgmError :: String -> a +panic x = Exception.throwDyn (Panic x) +pgmError x = Exception.throwDyn (ProgramError x) -- #-versions because panic can't return an unboxed int, and that's -- what TAG_ is with GHC at the moment. Ugh. (Simon) diff --git a/ghc/compiler/utils/UniqFM.lhs b/ghc/compiler/utils/UniqFM.lhs index 2d244259f5..aa357b8740 100644 --- a/ghc/compiler/utils/UniqFM.lhs +++ b/ghc/compiler/utils/UniqFM.lhs @@ -1,4 +1,4 @@ -% +%ilter % (c) The AQUA Project, Glasgow University, 1994-1998 % \section[UniqFM]{Specialised finite maps, for things with @Uniques@} @@ -34,7 +34,7 @@ module UniqFM ( foldUFM, mapUFM, elemUFM, - filterUFM, + filterUFM, filterUFM_Directly, sizeUFM, hashUFM, isNullUFM, @@ -103,6 +103,7 @@ intersectUFM_C :: (elt1 -> elt2 -> elt3) foldUFM :: (elt -> a -> a) -> a -> UniqFM elt -> a mapUFM :: (elt1 -> elt2) -> UniqFM elt1 -> UniqFM elt2 filterUFM :: (elt -> Bool) -> UniqFM elt -> UniqFM elt +filterUFM_Directly :: (Unique -> elt -> Bool) -> UniqFM elt -> UniqFM elt sizeUFM :: UniqFM elt -> Int hashUFM :: UniqFM elt -> Int @@ -192,6 +193,7 @@ data UniqFM ele FastInt -- the delta (UniqFM ele) (UniqFM ele) +-- INVARIANT: the children of a NodeUFM are never EmptyUFMs {- -- for debugging only :-) @@ -512,7 +514,14 @@ mapUFM fn EmptyUFM = EmptyUFM mapUFM fn fm = map_tree fn fm filterUFM fn EmptyUFM = EmptyUFM -filterUFM fn fm = filter_tree fn fm +filterUFM fn fm = filter_tree pred fm + where + pred (i::FastInt) e = fn e + +filterUFM_Directly fn EmptyUFM = EmptyUFM +filterUFM_Directly fn fm = filter_tree pred fm + where + pred i e = fn (mkUniqueGrimily (iBox i)) e \end{code} Note, this takes a long time, O(n), but @@ -704,11 +713,12 @@ map_tree f _ = panic "map_tree failed" \end{code} \begin{code} +filter_tree :: (FastInt -> a -> Bool) -> UniqFM a -> UniqFM a filter_tree f nd@(NodeUFM j p t1 t2) = mkSSNodeUFM (NodeUFMData j p) (filter_tree f t1) (filter_tree f t2) filter_tree f lf@(LeafUFM i obj) - | f obj = lf + | f i obj = lf | otherwise = EmptyUFM filter_tree f _ = panic "filter_tree failed" \end{code} |