From 5cf27e8f1731c52fe63a5b9615f927484164c61b Mon Sep 17 00:00:00 2001 From: partain Date: Thu, 16 May 1996 09:44:45 +0000 Subject: [PATCH] [project @ 1996-05-16 09:42:08 by partain] SLPJ changes through 960515 --- ghc/compiler/basicTypes/Id.lhs | 607 +++++++++++--------------- ghc/compiler/basicTypes/IdInfo.lhs | 8 +- ghc/compiler/basicTypes/Name.lhs | 70 ++- ghc/compiler/basicTypes/Unique.lhs | 48 ++- ghc/compiler/codeGen/CgBindery.lhs | 2 +- ghc/compiler/codeGen/CgCase.lhs | 15 +- ghc/compiler/codeGen/CgCon.lhs | 7 +- ghc/compiler/codeGen/CgConTbls.lhs | 2 +- ghc/compiler/codeGen/CgRetConv.lhs | 2 +- ghc/compiler/codeGen/CgTailCall.lhs | 9 +- ghc/compiler/codeGen/ClosureInfo.lhs | 14 +- ghc/compiler/coreSyn/CoreLift.lhs | 6 +- ghc/compiler/coreSyn/CoreLint.lhs | 67 +-- ghc/compiler/coreSyn/CoreUnfold.lhs | 4 +- ghc/compiler/coreSyn/CoreUtils.lhs | 2 +- ghc/compiler/coreSyn/PprCore.lhs | 4 +- ghc/compiler/deSugar/DsBinds.lhs | 2 +- ghc/compiler/deSugar/DsCCall.lhs | 6 +- ghc/compiler/deSugar/DsExpr.lhs | 20 +- ghc/compiler/deSugar/DsMonad.lhs | 4 +- ghc/compiler/deSugar/DsUtils.lhs | 7 +- ghc/compiler/deSugar/Match.lhs | 4 +- ghc/compiler/hsSyn/HsDecls.lhs | 2 +- ghc/compiler/hsSyn/HsExpr.lhs | 8 +- ghc/compiler/hsSyn/HsPat.lhs | 5 +- ghc/compiler/hsSyn/HsTypes.lhs | 21 +- ghc/compiler/main/CmdLineOpts.lhs | 26 +- ghc/compiler/main/ErrUtils.lhs | 9 +- ghc/compiler/main/MkIface.lhs | 175 ++++---- ghc/compiler/nativeGen/MachRegs.lhs | 6 +- ghc/compiler/nativeGen/PprMach.lhs | 5 +- ghc/compiler/prelude/PrelInfo.lhs | 11 +- ghc/compiler/prelude/PrelVals.lhs | 12 +- ghc/compiler/prelude/PrimOp.lhs | 7 +- ghc/compiler/prelude/TysWiredIn.lhs | 14 +- ghc/compiler/profiling/CostCentre.lhs | 5 +- ghc/compiler/reader/ReadPrefix.lhs | 4 +- ghc/compiler/rename/ParseIface.y | 2 + ghc/compiler/rename/Rename.lhs | 28 +- ghc/compiler/rename/RnExpr.lhs | 4 +- ghc/compiler/rename/RnIfaces.lhs | 11 +- ghc/compiler/rename/RnMonad.lhs | 5 +- ghc/compiler/rename/RnNames.lhs | 29 +- ghc/compiler/rename/RnSource.lhs | 21 +- ghc/compiler/rename/RnUtils.lhs | 8 +- ghc/compiler/simplCore/AnalFBWW.lhs | 4 +- ghc/compiler/simplCore/FloatIn.lhs | 11 +- ghc/compiler/simplCore/FoldrBuildWW.lhs | 4 +- ghc/compiler/simplCore/MagicUFs.lhs | 10 +- ghc/compiler/simplCore/OccurAnal.lhs | 4 +- ghc/compiler/simplCore/SAT.lhs | 4 +- ghc/compiler/simplCore/SATMonad.lhs | 4 +- ghc/compiler/simplCore/SetLevels.lhs | 14 +- ghc/compiler/simplCore/SimplCase.lhs | 6 +- ghc/compiler/simplCore/SimplEnv.lhs | 74 ++-- ghc/compiler/simplCore/SimplMonad.lhs | 4 +- ghc/compiler/simplCore/SimplUtils.lhs | 6 +- ghc/compiler/simplCore/SimplVar.lhs | 6 +- ghc/compiler/simplCore/Simplify.lhs | 34 +- ghc/compiler/simplStg/LambdaLift.lhs | 4 +- ghc/compiler/simplStg/SatStgRhs.lhs | 4 +- ghc/compiler/simplStg/StgSATMonad.lhs | 2 +- ghc/compiler/simplStg/UpdAnal.lhs | 4 +- ghc/compiler/specialise/SpecUtils.lhs | 2 +- ghc/compiler/specialise/Specialise.lhs | 20 +- ghc/compiler/stgSyn/CoreToStg.lhs | 4 +- ghc/compiler/stgSyn/StgLint.lhs | 22 +- ghc/compiler/stranal/SaAbsInt.lhs | 16 +- ghc/compiler/stranal/StrictAnal.lhs | 4 +- ghc/compiler/stranal/WwLib.lhs | 10 +- ghc/compiler/typecheck/GenSpecEtc.lhs | 4 +- ghc/compiler/typecheck/Inst.lhs | 80 ++-- ghc/compiler/typecheck/TcBinds.lhs | 6 +- ghc/compiler/typecheck/TcClassDcl.lhs | 12 +- ghc/compiler/typecheck/TcDefaults.lhs | 4 +- ghc/compiler/typecheck/TcDeriv.lhs | 12 +- ghc/compiler/typecheck/TcEnv.lhs | 27 +- ghc/compiler/typecheck/TcExpr.lhs | 27 +- ghc/compiler/typecheck/TcGenDeriv.lhs | 6 +- ghc/compiler/typecheck/TcHsSyn.lhs | 704 +++++++++++++++++-------------- ghc/compiler/typecheck/TcInstDcls.lhs | 28 +- ghc/compiler/typecheck/TcInstUtil.lhs | 32 +- ghc/compiler/typecheck/TcKind.lhs | 6 +- ghc/compiler/typecheck/TcModule.lhs | 74 ++-- ghc/compiler/typecheck/TcMonad.lhs | 5 +- ghc/compiler/typecheck/TcPragmas.lhs | 6 +- ghc/compiler/typecheck/TcSimplify.lhs | 158 ++++--- ghc/compiler/typecheck/TcTyClsDecls.lhs | 47 +-- ghc/compiler/typecheck/TcTyDecls.lhs | 96 +++-- ghc/compiler/typecheck/TcType.lhs | 182 ++++---- ghc/compiler/typecheck/Unify.lhs | 4 +- ghc/compiler/types/Class.lhs | 6 +- ghc/compiler/types/Kind.lhs | 10 +- ghc/compiler/types/PprType.lhs | 12 +- ghc/compiler/types/TyCon.lhs | 2 + ghc/compiler/types/TyVar.lhs | 8 +- ghc/compiler/types/Type.lhs | 252 ++++++++--- ghc/compiler/utils/Pretty.lhs | 3 +- ghc/compiler/utils/SST.lhs | 8 +- ghc/compiler/utils/Unpretty.lhs | 5 +- ghc/compiler/utils/Util.lhs | 52 +-- 101 files changed, 1858 insertions(+), 1625 deletions(-) diff --git a/ghc/compiler/basicTypes/Id.lhs b/ghc/compiler/basicTypes/Id.lhs index 152b9f3..59d4697 100644 --- a/ghc/compiler/basicTypes/Id.lhs +++ b/ghc/compiler/basicTypes/Id.lhs @@ -105,9 +105,9 @@ import IdInfo import Maybes ( maybeToBool ) import Name ( appendRdr, nameUnique, mkLocalName, isLocalName, isLocallyDefinedName, isPreludeDefinedName, - mkTupleDataConName, mkCompoundName, + mkTupleDataConName, mkCompoundName, mkCompoundName2, isLexSym, isLexSpecialSym, getLocalName, - isLocallyDefined, isPreludeDefined, + isLocallyDefined, isPreludeDefined, changeUnique, getOccName, moduleNamePair, origName, nameOf, isExported, ExportFlag(..), RdrName(..), Name @@ -153,6 +153,7 @@ ToDo: possibly cache other stuff in the single-constructor @Id@ type. \begin{code} data GenId ty = Id Unique -- Key for fast comparison + Name ty -- Id's type; used all the time; IdDetails -- Stuff about individual kinds of Ids. PragmaInfo -- Properties of this Id requested by programmer @@ -167,23 +168,23 @@ data IdDetails ---------------- Local values - = LocalId Name -- Local name; mentioned by the user - Bool -- True <=> no free type vars + = LocalId Bool -- Local name; mentioned by the user + -- True <=> no free type vars - | SysLocalId Name -- Local name; made up by the compiler - Bool -- as for LocalId + | SysLocalId Bool -- Local name; made up by the compiler + -- as for LocalId - | SpecPragmaId Name -- Local name; introduced by the compiler + | SpecPragmaId -- Local name; introduced by the compiler (Maybe Id) -- for explicit specid in pragma Bool -- as for LocalId ---------------- Global values - | ImportedId Name -- Global name (Imported or Implicit); Id imported from an interface + | ImportedId -- Global name (Imported or Implicit); Id imported from an interface - | PreludeId Name -- Global name (Builtin); Builtin prelude Ids + | PreludeId -- Global name (Builtin); Builtin prelude Ids - | TopLevId Name -- Global name (LocalDef); Top-level in the orig source pgm + | TopLevId -- Global name (LocalDef); Top-level in the orig source pgm -- (not moved there by transformations). -- a TopLevId's type may contain free type variables, if @@ -191,8 +192,7 @@ data IdDetails ---------------- Data constructors - | DataConId Name - ConTag + | DataConId ConTag [StrictnessMark] -- Strict args; length = arity [FieldLabel] -- Field labels for this constructor @@ -201,8 +201,7 @@ data IdDetails -- forall tyvars . theta_ty => -- unitype_1 -> ... -> unitype_n -> tycon tyvars - | TupleConId Name - Int -- Its arity + | TupleConId Int -- Its arity | RecordSelId FieldLabel @@ -237,7 +236,6 @@ data IdDetails -- The "a" is irrelevant. As it is too painful to -- actually do comparisons that way, we kindly supply -- a Unique for that purpose. - Bool -- True <=> from an instance decl in this mod (Maybe Module) -- module where instance came from; Nothing => Prelude -- see below @@ -246,10 +244,9 @@ data IdDetails Class -- Uniquely identified by: Type -- (class, type, classop) triple ClassOp - Bool -- True => from an instance decl in this mod (Maybe Module) -- module where instance came from; Nothing => Prelude - | InstId Name -- An instance of a dictionary, class operation, + | InstId -- An instance of a dictionary, class operation, -- or overloaded value (Local name) Bool -- as for LocalId @@ -265,14 +262,12 @@ data IdDetails | WorkerId -- A "worker" for some other Id Id -- Id for which this is a worker - type ConTag = Int type DictVar = Id type DictFun = Id type DataCon = Id \end{code} - DictFunIds are generated from instance decls. \begin{verbatim} class Foo a where @@ -456,129 +451,129 @@ properties, but they may not. \begin{code} unsafeGenId2Id :: GenId ty -> Id -unsafeGenId2Id (Id u ty d p i) = Id u (panic "unsafeGenId2Id:ty") d p i +unsafeGenId2Id (Id u n ty d p i) = Id u n (panic "unsafeGenId2Id:ty") d p i isDataCon id = is_data (unsafeGenId2Id id) where - is_data (Id _ _ (DataConId _ _ _ _ _ _ _ _) _ _) = True - is_data (Id _ _ (TupleConId _ _) _ _) = True - is_data (Id _ _ (SpecId unspec _ _) _ _) = is_data unspec + is_data (Id _ _ _ (DataConId _ _ _ _ _ _ _) _ _) = True + is_data (Id _ _ _ (TupleConId _) _ _) = True + is_data (Id _ _ _ (SpecId unspec _ _) _ _) = is_data unspec is_data other = False isTupleCon id = is_tuple (unsafeGenId2Id id) where - is_tuple (Id _ _ (TupleConId _ _) _ _) = True - is_tuple (Id _ _ (SpecId unspec _ _) _ _) = is_tuple unspec + is_tuple (Id _ _ _ (TupleConId _) _ _) = True + is_tuple (Id _ _ _ (SpecId unspec _ _) _ _) = is_tuple unspec is_tuple other = False {-LATER: -isSpecId_maybe (Id _ _ (SpecId unspec ty_maybes _) _ _) +isSpecId_maybe (Id _ _ _ (SpecId unspec ty_maybes _) _ _) = ASSERT(not (maybeToBool (isSpecId_maybe unspec))) Just (unspec, ty_maybes) isSpecId_maybe other_id = Nothing -isSpecPragmaId_maybe (Id _ _ (SpecPragmaId _ specid _) _ _) +isSpecPragmaId_maybe (Id _ _ _ (SpecPragmaId specid _) _ _) = Just specid isSpecPragmaId_maybe other_id = Nothing -} \end{code} -@toplevelishId@ tells whether an @Id@ {\em may} be defined in a -nested @let(rec)@ (returns @False@), or whether it is {\em sure} to be -defined at top level (returns @True@). This is used to decide whether -the @Id@ is a candidate free variable. NB: you are only {\em sure} +@toplevelishId@ tells whether an @Id@ {\em may} be defined in a nested +@let(rec)@ (returns @False@), or whether it is {\em sure} to be +defined at top level (returns @True@). This is used to decide whether +the @Id@ is a candidate free variable. NB: you are only {\em sure} about something if it returns @True@! \begin{code} -toplevelishId :: Id -> Bool -idHasNoFreeTyVars :: Id -> Bool +toplevelishId :: Id -> Bool +idHasNoFreeTyVars :: Id -> Bool -toplevelishId (Id _ _ details _ _) +toplevelishId (Id _ _ _ details _ _) = chk details where - chk (DataConId _ _ _ _ _ _ _ _) = True - chk (TupleConId _ _) = True + chk (DataConId _ _ _ _ _ _ _) = True + chk (TupleConId _) = True chk (RecordSelId _) = True - chk (ImportedId _) = True - chk (PreludeId _) = True - chk (TopLevId _) = True -- NB: see notes + chk ImportedId = True + chk PreludeId = True + chk TopLevId = True -- NB: see notes chk (SuperDictSelId _ _) = True chk (MethodSelId _ _) = True chk (DefaultMethodId _ _ _) = True - chk (DictFunId _ _ _ _) = True - chk (ConstMethodId _ _ _ _ _) = True + chk (DictFunId _ _ _) = True + chk (ConstMethodId _ _ _ _) = True chk (SpecId unspec _ _) = toplevelishId unspec -- depends what the unspecialised thing is chk (WorkerId unwrkr) = toplevelishId unwrkr - chk (InstId _ _) = False -- these are local - chk (LocalId _ _) = False - chk (SysLocalId _ _) = False - chk (SpecPragmaId _ _ _) = False + chk (InstId _) = False -- these are local + chk (LocalId _) = False + chk (SysLocalId _) = False + chk (SpecPragmaId _ _) = False -idHasNoFreeTyVars (Id _ _ details _ info) +idHasNoFreeTyVars (Id _ _ _ details _ info) = chk details where - chk (DataConId _ _ _ _ _ _ _ _) = True - chk (TupleConId _ _) = True + chk (DataConId _ _ _ _ _ _ _) = True + chk (TupleConId _) = True chk (RecordSelId _) = True - chk (ImportedId _) = True - chk (PreludeId _) = True - chk (TopLevId _) = True + chk ImportedId = True + chk PreludeId = True + chk TopLevId = True chk (SuperDictSelId _ _) = True chk (MethodSelId _ _) = True chk (DefaultMethodId _ _ _) = True - chk (DictFunId _ _ _ _) = True - chk (ConstMethodId _ _ _ _ _) = True + chk (DictFunId _ _ _) = True + chk (ConstMethodId _ _ _ _) = True chk (WorkerId unwrkr) = idHasNoFreeTyVars unwrkr - chk (InstId _ no_free_tvs) = no_free_tvs chk (SpecId _ _ no_free_tvs) = no_free_tvs - chk (LocalId _ no_free_tvs) = no_free_tvs - chk (SysLocalId _ no_free_tvs) = no_free_tvs - chk (SpecPragmaId _ _ no_free_tvs) = no_free_tvs + chk (InstId no_free_tvs) = no_free_tvs + chk (LocalId no_free_tvs) = no_free_tvs + chk (SysLocalId no_free_tvs) = no_free_tvs + chk (SpecPragmaId _ no_free_tvs) = no_free_tvs \end{code} \begin{code} -isTopLevId (Id _ _ (TopLevId _) _ _) = True -isTopLevId other = False +isTopLevId (Id _ _ _ TopLevId _ _) = True +isTopLevId other = False -isImportedId (Id _ _ (ImportedId _) _ _) = True -isImportedId other = False +isImportedId (Id _ _ _ ImportedId _ _) = True +isImportedId other = False -isBottomingId (Id _ _ _ _ info) = bottomIsGuaranteed (getInfo info) +isBottomingId (Id _ _ _ _ _ info) = bottomIsGuaranteed (getInfo info) -isSysLocalId (Id _ _ (SysLocalId _ _) _ _) = True +isSysLocalId (Id _ _ _ (SysLocalId _) _ _) = True isSysLocalId other = False -isSpecPragmaId (Id _ _ (SpecPragmaId _ _ _) _ _) = True +isSpecPragmaId (Id _ _ _ (SpecPragmaId _ _) _ _) = True isSpecPragmaId other = False -isMethodSelId (Id _ _ (MethodSelId _ _) _ _) = True -isMethodSelId _ = False +isMethodSelId (Id _ _ _ (MethodSelId _ _) _ _) = True +isMethodSelId _ = False -isDefaultMethodId (Id _ _ (DefaultMethodId _ _ _) _ _) = True -isDefaultMethodId other = False +isDefaultMethodId (Id _ _ _ (DefaultMethodId _ _ _) _ _) = True +isDefaultMethodId other = False -isDefaultMethodId_maybe (Id _ _ (DefaultMethodId cls clsop err) _ _) +isDefaultMethodId_maybe (Id _ _ _ (DefaultMethodId cls clsop err) _ _) = Just (cls, clsop, err) isDefaultMethodId_maybe other = Nothing -isDictFunId (Id _ _ (DictFunId _ _ _ _) _ _) = True +isDictFunId (Id _ _ _ (DictFunId _ _ _) _ _) = True isDictFunId other = False -isConstMethodId (Id _ _ (ConstMethodId _ _ _ _ _) _ _) = True +isConstMethodId (Id _ _ _ (ConstMethodId _ _ _ _) _ _) = True isConstMethodId other = False -isConstMethodId_maybe (Id _ _ (ConstMethodId cls ty clsop _ _) _ _) +isConstMethodId_maybe (Id _ _ _ (ConstMethodId cls ty clsop _) _ _) = Just (cls, ty, clsop) isConstMethodId_maybe other = Nothing -isSuperDictSelId_maybe (Id _ _ (SuperDictSelId c sc) _ _) = Just (c, sc) +isSuperDictSelId_maybe (Id _ _ _ (SuperDictSelId c sc) _ _) = Just (c, sc) isSuperDictSelId_maybe other_id = Nothing -isWorkerId (Id _ _ (WorkerId _) _ _) = True +isWorkerId (Id _ _ _ (WorkerId _) _ _) = True isWorkerId other = False {-LATER: @@ -607,16 +602,16 @@ pprIdInUnfolding in_scopes v -- ones to think about: else let - (Id _ _ v_details _ _) = v + (Id _ _ _ v_details _ _) = v in case v_details of -- these ones must have been exported by their original module - ImportedId _ -> pp_full_name - PreludeId _ -> pp_full_name + ImportedId -> pp_full_name + PreludeId -> pp_full_name -- these ones' exportedness checked later... - TopLevId _ -> pp_full_name - DataConId _ _ _ _ _ _ _ _ -> pp_full_name + TopLevId -> pp_full_name + DataConId _ _ _ _ _ _ _ -> pp_full_name RecordSelId lbl -> ppr sty lbl @@ -630,9 +625,9 @@ pprIdInUnfolding in_scopes v -- instance-ish things: should we try to figure out -- *exactly* which extra instances have to be exported? (ToDo) - DictFunId c t _ _ + DictFunId c t _ -> ppCat [ppPStr SLIT("_DFUN_"), pp_class c, pp_type t] - ConstMethodId c t o _ _ + ConstMethodId c t o _ -> ppCat [ppPStr SLIT("_CONSTM_"), pp_class c, pp_class_op o, pp_type t] -- specialisations and workers @@ -718,7 +713,7 @@ whatsMentionedInId in_scopes v -- ones to think about: else let - (Id _ _ v_details _ _) = v + (Id _ _ _ v_details _ _) = v in case v_details of -- specialisations and workers @@ -743,7 +738,7 @@ Tell them who my wrapper function is. {-LATER: myWrapperMaybe :: Id -> Maybe Id -myWrapperMaybe (Id _ _ (WorkerId my_wrapper) _ _) = Just my_wrapper +myWrapperMaybe (Id _ _ _ (WorkerId my_wrapper) _ _) = Just my_wrapper myWrapperMaybe other_id = Nothing -} \end{code} @@ -761,7 +756,7 @@ unfoldingUnfriendlyId id | not (externallyVisibleId id) -- that settles that... = True -unfoldingUnfriendlyId (Id _ _ (WorkerId wrapper) _ _) +unfoldingUnfriendlyId (Id _ _ _ (WorkerId wrapper) _ _) = class_thing wrapper where -- "class thing": If we're going to use this worker Id in @@ -770,19 +765,19 @@ unfoldingUnfriendlyId (Id _ _ (WorkerId wrapper) _ _) -- is not always possible: in precisely those cases where -- we pass tcGenPragmas a "Nothing" for its "ty_maybe". - class_thing (Id _ _ (SuperDictSelId _ _) _ _) = True - class_thing (Id _ _ (MethodSelId _ _) _ _) = True - class_thing (Id _ _ (DefaultMethodId _ _ _) _ _) = True + class_thing (Id _ _ _ (SuperDictSelId _ _) _ _) = True + class_thing (Id _ _ _ (MethodSelId _ _) _ _) = True + class_thing (Id _ _ _ (DefaultMethodId _ _ _) _ _) = True class_thing other = False -unfoldingUnfriendlyId (Id _ _ (SpecId d@(Id _ _ _ dfun@(DictFunId _ t _ _)) _ _) _ _) +unfoldingUnfriendlyId (Id _ _ _ (SpecId d@(Id _ _ _ dfun@(DictFunId _ t _)) _ _) _ _) -- a SPEC of a DictFunId can end up w/ gratuitous -- TyVar(Templates) in the i/face; only a problem -- if -fshow-pragma-name-errs; but we can do without the pain. -- A HACK in any case (WDP 94/05/02) = naughty_DictFunId dfun -unfoldingUnfriendlyId d@(Id _ _ dfun@(DictFunId _ t _ _) _ _) +unfoldingUnfriendlyId d@(Id _ _ _ dfun@(DictFunId _ t _) _ _) = naughty_DictFunId dfun -- similar deal... unfoldingUnfriendlyId other_id = False -- is friendly in all other cases @@ -790,8 +785,8 @@ unfoldingUnfriendlyId other_id = False -- is friendly in all other cases naughty_DictFunId :: IdDetails -> Bool -- True <=> has a TyVar(Template) in the "type" part of its "name" -naughty_DictFunId (DictFunId _ _ False _) = False -- came from outside; must be OK -naughty_DictFunId (DictFunId _ ty _ _) +naughty_DictFunId (DictFunId _ _ _) = panic "False" -- came from outside; must be OK +naughty_DictFunId (DictFunId _ ty _) = not (isGroundTy ty) -} \end{code} @@ -807,7 +802,7 @@ compiling the prelude, the compiler may not recognise that as true. \begin{code} externallyVisibleId :: Id -> Bool -externallyVisibleId id@(Id _ _ details _ _) +externallyVisibleId id@(Id _ _ _ details _ _) = if isLocallyDefined id then toplevelishId id && isExported id && not (weird_datacon details) else @@ -825,12 +820,12 @@ externallyVisibleId id@(Id _ _ details _ _) -- "Mumble" is externally visible... {- LATER: if at all: - weird_datacon (DataConId _ _ _ _ _ _ _ tycon) + weird_datacon (DataConId _ _ _ _ _ _ tycon) = maybeToBool (maybePurelyLocalTyCon tycon) -} weird_datacon not_a_datacon_therefore_not_weird = False - weird_tuplecon (TupleConId _ arity) + weird_tuplecon (TupleConId arity) = arity > 32 -- sigh || isBigTupleTyCon tycon -- generated *purely* for local use weird_tuplecon _ = False \end{code} @@ -838,8 +833,8 @@ externallyVisibleId id@(Id _ _ details _ _) \begin{code} idWantsToBeINLINEd :: Id -> Bool -idWantsToBeINLINEd (Id _ _ _ IWantToBeINLINEd _) = True -idWantsToBeINLINEd _ = False +idWantsToBeINLINEd (Id _ _ _ _ IWantToBeINLINEd _) = True +idWantsToBeINLINEd _ = False \end{code} For @unlocaliseId@: See the brief commentary in @@ -849,35 +844,35 @@ For @unlocaliseId@: See the brief commentary in {-LATER: unlocaliseId :: FAST_STRING{-modulename-} -> Id -> Maybe Id -unlocaliseId mod (Id u ty info (TopLevId fn)) - = Just (Id u ty info (TopLevId (unlocaliseFullName fn))) +unlocaliseId mod (Id u fn ty info TopLevId) + = Just (Id u (unlocaliseFullName fn) ty info TopLevId) -unlocaliseId mod (Id u ty info (LocalId sn no_ftvs)) +unlocaliseId mod (Id u sn ty info (LocalId no_ftvs)) = --false?: ASSERT(no_ftvs) let full_name = unlocaliseShortName mod u sn in - Just (Id u ty info (TopLevId full_name)) + Just (Id u full_name ty info TopLevId) -unlocaliseId mod (Id u ty info (SysLocalId sn no_ftvs)) +unlocaliseId mod (Id u sn ty info (SysLocalId no_ftvs)) = --false?: on PreludeGlaST: ASSERT(no_ftvs) let full_name = unlocaliseShortName mod u sn in - Just (Id u ty info (TopLevId full_name)) + Just (Id u full_name ty info TopLevId) -unlocaliseId mod (Id u ty info (SpecId unspec ty_maybes no_ftvs)) +unlocaliseId mod (Id u n ty info (SpecId unspec ty_maybes no_ftvs)) = case unlocalise_parent mod u unspec of Nothing -> Nothing - Just xx -> Just (Id u ty info (SpecId xx ty_maybes no_ftvs)) + Just xx -> Just (Id u n ty info (SpecId xx ty_maybes no_ftvs)) -unlocaliseId mod (Id u ty info (WorkerId unwrkr)) +unlocaliseId mod (Id u n ty info (WorkerId unwrkr)) = case unlocalise_parent mod u unwrkr of Nothing -> Nothing - Just xx -> Just (Id u ty info (WorkerId xx)) + Just xx -> Just (Id u n ty info (WorkerId xx)) -unlocaliseId mod (Id u ty info (InstId name no_ftvs)) - = Just (Id u ty info (TopLevId full_name)) +unlocaliseId mod (Id u name ty info (InstId no_ftvs)) + = Just (Id u full_name ty info TopLevId) -- type might be wrong, but it hardly matters -- at this stage (just before printing C) ToDo where @@ -890,19 +885,19 @@ unlocaliseId mod other_id = Nothing -- we have to be Very Careful for workers/specs of -- local functions! -unlocalise_parent mod uniq (Id _ ty info (LocalId sn no_ftvs)) +unlocalise_parent mod uniq (Id _ sn ty info (LocalId no_ftvs)) = --false?: ASSERT(no_ftvs) let full_name = unlocaliseShortName mod uniq sn in - Just (Id uniq ty info (TopLevId full_name)) + Just (Id uniq full_name ty info TopLevId) -unlocalise_parent mod uniq (Id _ ty info (SysLocalId sn no_ftvs)) +unlocalise_parent mod uniq (Id _ sn ty info (SysLocalId no_ftvs)) = --false?: ASSERT(no_ftvs) let full_name = unlocaliseShortName mod uniq sn in - Just (Id uniq ty info (TopLevId full_name)) + Just (Id uniq full_name ty info TopLevId) unlocalise_parent mod uniq other_id = unlocaliseId mod other_id -- we're OK otherwise @@ -921,7 +916,7 @@ type TypeEnv = TyVarEnv Type applyTypeEnvToId :: TypeEnv -> Id -> Id -applyTypeEnvToId type_env id@(Id _ ty _ _ _) +applyTypeEnvToId type_env id@(Id _ _ ty _ _ _) | idHasNoFreeTyVars id = id | otherwise @@ -931,15 +926,13 @@ applyTypeEnvToId type_env id@(Id _ ty _ _ _) \end{code} \begin{code} -apply_to_Id :: (Type -> Type) - -> Id - -> Id +apply_to_Id :: (Type -> Type) -> Id -> Id -apply_to_Id ty_fn (Id u ty details prag info) +apply_to_Id ty_fn (Id u n ty details prag info) = let new_ty = ty_fn ty in - Id u new_ty (apply_to_details details) prag (apply_to_IdInfo ty_fn info) + Id u n new_ty (apply_to_details details) prag (apply_to_IdInfo ty_fn info) where apply_to_details (SpecId unspec ty_maybes no_ftvs) = let @@ -971,14 +964,14 @@ with pointers to the substitution: it {\em must} be single-threaded. {-LATER: applySubstToId :: Subst -> Id -> (Subst, Id) -applySubstToId subst id@(Id u ty info details) +applySubstToId subst id@(Id u n ty info details) -- *cannot* have a "idHasNoFreeTyVars" get-out clause -- because, in the typechecker, we are still -- *concocting* the types. = case (applySubstToTy subst ty) of { (s2, new_ty) -> case (applySubstToIdInfo s2 info) of { (s3, new_info) -> case (apply_to_details s3 new_ty details) of { (s4, new_details) -> - (s4, Id u new_ty new_info new_details) }}} + (s4, Id u n new_ty new_info new_details) }}} where apply_to_details subst _ (InstId inst no_ftvs) = case (applySubstToInst subst inst) of { (s2, new_inst) -> @@ -1003,107 +996,6 @@ applySubstToId subst id@(Id u ty info details) -} \end{code} -\begin{code} -getIdNamePieces :: Bool {-show Uniques-} -> GenId ty -> [FAST_STRING] - -getIdNamePieces show_uniqs id - = get (unsafeGenId2Id id) - where - get (Id u _ details _ _) - = case details of - DataConId n _ _ _ _ _ _ _ -> - case (moduleNamePair n) of { (mod, name) -> - if isPreludeDefinedName n then [name] else [mod, name] } - - TupleConId n _ -> [nameOf (origName n)] - - RecordSelId lbl -> - let n = fieldLabelName lbl - in - case (moduleNamePair n) of { (mod, name) -> - if isPreludeDefinedName n then [name] else [mod, name] } - - ImportedId n -> get_fullname_pieces n - PreludeId n -> get_fullname_pieces n - TopLevId n -> get_fullname_pieces n - - SuperDictSelId c sc -> - case (moduleNamePair c) of { (c_mod, c_name) -> - case (moduleNamePair sc) of { (sc_mod, sc_name) -> - let - c_bits = if isPreludeDefined c - then [c_name] - else [c_mod, c_name] - - sc_bits= if isPreludeDefined sc - then [sc_name] - else [sc_mod, sc_name] - in - [SLIT("sdsel")] ++ c_bits ++ sc_bits }} - - MethodSelId clas op -> - case (moduleNamePair clas) of { (c_mod, c_name) -> - case (classOpString op) of { op_name -> - if isPreludeDefined clas - then [op_name] - else [c_mod, c_name, op_name] - } } - - DefaultMethodId clas op _ -> - case (moduleNamePair clas) of { (c_mod, c_name) -> - case (classOpString op) of { op_name -> - if isPreludeDefined clas - then [SLIT("defm"), op_name] - else [SLIT("defm"), c_mod, c_name, op_name] }} - - DictFunId c ty _ _ -> - case (moduleNamePair c) of { (c_mod, c_name) -> - let - c_bits = if isPreludeDefined c - then [c_name] - else [c_mod, c_name] - - ty_bits = getTypeString ty - in - [SLIT("dfun")] ++ c_bits ++ ty_bits } - - ConstMethodId c ty o _ _ -> - case (moduleNamePair c) of { (c_mod, c_name) -> - case (getTypeString ty) of { ty_bits -> - case (classOpString o) of { o_name -> - case (if isPreludeDefined c - then [c_name] - else [c_mod, c_name]) of { c_bits -> - [SLIT("const")] ++ c_bits ++ ty_bits ++ [o_name] }}}} - - -- if the unspecialised equiv is "top-level", - -- the name must be concocted from its name and the - -- names of the types to which specialised... - - SpecId unspec ty_maybes _ -> - get unspec ++ (if not (toplevelishId unspec) - then [showUnique u] - else concat (map typeMaybeString ty_maybes)) - - WorkerId unwrkr -> - get unwrkr ++ (if not (toplevelishId unwrkr) - then [showUnique u] - else [SLIT("wrk")]) - - LocalId n _ -> let local = getLocalName n in - if show_uniqs then [local, showUnique u] else [local] - InstId n _ -> [getLocalName n, showUnique u] - SysLocalId n _ -> [getLocalName n, showUnique u] - SpecPragmaId n _ _ -> [getLocalName n, showUnique u] - -get_fullname_pieces :: Name -> [FAST_STRING] -get_fullname_pieces n - = case (moduleNamePair n) of { (mod, name) -> - if isPreludeDefinedName n - then [name] - else [mod, name] } -\end{code} - %************************************************************************ %* * \subsection[Id-type-funs]{Type-related @Id@ functions} @@ -1113,7 +1005,7 @@ get_fullname_pieces n \begin{code} idType :: GenId ty -> ty -idType (Id _ ty _ _ _) = ty +idType (Id _ _ ty _ _ _) = ty \end{code} \begin{code} @@ -1131,8 +1023,8 @@ idPrimRep i = typePrimRep (idType i) \begin{code} {-LATER: -getInstIdModule (Id _ _ _ (DictFunId _ _ _ mod)) = mod -getInstIdModule (Id _ _ _ (ConstMethodId _ _ _ _ mod)) = mod +getInstIdModule (Id _ _ _ (DictFunId _ _ mod)) = mod +getInstIdModule (Id _ _ _ (ConstMethodId _ _ _ mod)) = mod getInstIdModule other = panic "Id:getInstIdModule" -} \end{code} @@ -1144,19 +1036,45 @@ getInstIdModule other = panic "Id:getInstIdModule" %************************************************************************ \begin{code} -mkSuperDictSelId u c sc ty info = Id u ty (SuperDictSelId c sc) NoPragmaInfo info -mkMethodSelId u c op ty info = Id u ty (MethodSelId c op) NoPragmaInfo info -mkDefaultMethodId u c op gen ty info = Id u ty (DefaultMethodId c op gen) NoPragmaInfo info +mkSuperDictSelId u c sc ty info + = Id u n ty (SuperDictSelId c sc) NoPragmaInfo info + where + cname = getName c -- we get other info out of here + + n = mkCompoundName u SLIT("sdsel") [origName cname, origName sc] cname -mkDictFunId u c ity full_ty from_here mod info - = Id u full_ty (DictFunId c ity from_here mod) NoPragmaInfo info +mkMethodSelId u c op ty info + = Id u n ty (MethodSelId c op) NoPragmaInfo info + where + cname = getName c -- we get other info out of here -mkConstMethodId u c op ity full_ty from_here mod info - = Id u full_ty (ConstMethodId c ity op from_here mod) NoPragmaInfo info + n = mkCompoundName u SLIT("meth") [origName cname, Unqual (classOpString op)] cname -mkWorkerId u unwrkr ty info = Id u ty (WorkerId unwrkr) NoPragmaInfo info +mkDefaultMethodId u c op gen ty info + = Id u n ty (DefaultMethodId c op gen) NoPragmaInfo info + where + cname = getName c -- we get other info out of here -mkInstId uniq ty name = Id uniq ty (InstId name (no_free_tvs ty)) NoPragmaInfo noIdInfo + n = mkCompoundName u SLIT("defm") [origName cname, Unqual (classOpString op)] cname + +mkDictFunId u c ity full_ty from_here locn mod info + = Id u n full_ty (DictFunId c ity mod) NoPragmaInfo info + where + n = mkCompoundName2 u SLIT("dfun") [origName c] (getTypeString ity) from_here locn + +mkConstMethodId u c op ity full_ty from_here locn mod info + = Id u n full_ty (ConstMethodId c ity op mod) NoPragmaInfo info + where + n = mkCompoundName2 u SLIT("const") [origName c, Unqual (classOpString op)] (getTypeString ity) from_here locn + +mkWorkerId u unwrkr ty info + = Id u n ty (WorkerId unwrkr) NoPragmaInfo info + where + unwrkr_name = getName unwrkr + + n = mkCompoundName u SLIT("wrk") [origName unwrkr_name] unwrkr_name + +mkInstId u ty name = Id u (changeUnique name u) ty (InstId (no_free_tvs ty)) NoPragmaInfo noIdInfo {-LATER: getConstMethodId clas op ty @@ -1184,12 +1102,12 @@ getConstMethodId clas op ty %************************************************************************ \begin{code} -mkImported n ty info = Id (nameUnique n) ty (ImportedId n) NoPragmaInfo info -mkPreludeId n ty info = Id (nameUnique n) ty (PreludeId n) NoPragmaInfo info +mkImported n ty info = Id (nameUnique n) n ty ImportedId NoPragmaInfo info +mkPreludeId n ty info = Id (nameUnique n) n ty PreludeId NoPragmaInfo info {-LATER: updateIdType :: Id -> Type -> Id -updateIdType (Id u _ info details) ty = Id u ty info details +updateIdType (Id u n _ info details) ty = Id u n ty info details -} \end{code} @@ -1204,20 +1122,20 @@ no_free_tvs ty = isEmptyTyVarSet (tyVarsOfType ty) mkSysLocal, mkUserLocal :: FAST_STRING -> Unique -> MyTy a b -> SrcLoc -> MyId a b mkSysLocal str uniq ty loc - = Id uniq ty (SysLocalId (mkLocalName uniq str loc) (no_free_tvs ty)) NoPragmaInfo noIdInfo + = Id uniq (mkLocalName uniq str loc) ty (SysLocalId (no_free_tvs ty)) NoPragmaInfo noIdInfo mkUserLocal str uniq ty loc - = Id uniq ty (LocalId (mkLocalName uniq str loc) (no_free_tvs ty)) NoPragmaInfo noIdInfo + = Id uniq (mkLocalName uniq str loc) ty (LocalId (no_free_tvs ty)) NoPragmaInfo noIdInfo -- mkUserId builds a local or top-level Id, depending on the name given mkUserId :: Name -> MyTy a b -> PragmaInfo -> MyId a b mkUserId name ty pragma_info | isLocalName name - = Id (nameUnique name) ty (LocalId name (no_free_tvs ty)) pragma_info noIdInfo + = Id (nameUnique name) name ty (LocalId (no_free_tvs ty)) pragma_info noIdInfo | otherwise - = Id (nameUnique name) ty - (if isLocallyDefinedName name then TopLevId name else ImportedId name) - pragma_info noIdInfo + = Id (nameUnique name) name ty + (if isLocallyDefinedName name then TopLevId else ImportedId) + pragma_info noIdInfo \end{code} @@ -1227,26 +1145,26 @@ mkUserId name ty pragma_info -- for a SpecPragmaId being created by the compiler out of thin air... mkSpecPragmaId :: FAST_STRING -> Unique -> Type -> Maybe Id -> SrcLoc -> Id mkSpecPragmaId str uniq ty specid loc - = Id uniq ty noIdInfo (SpecPragmaId (mkShortName str loc) specid (no_free_tvs ty)) + = Id uniq (mkShortName str loc) ty noIdInfo (SpecPragmaId specid (no_free_tvs ty)) -- for new SpecId mkSpecId u unspec ty_maybes ty info = ASSERT(not (maybeToBool (isSpecId_maybe unspec))) - Id u ty info (SpecId unspec ty_maybes (no_free_tvs ty)) + Id u n ty info (SpecId unspec ty_maybes (no_free_tvs ty)) -- Specialised version of constructor: only used in STG and code generation -- Note: The specialsied Id has the same unique as the unspeced Id -mkSameSpecCon ty_maybes unspec@(Id u ty info details) +mkSameSpecCon ty_maybes unspec@(Id u n ty info details) = ASSERT(isDataCon unspec) ASSERT(not (maybeToBool (isSpecId_maybe unspec))) - Id u new_ty info (SpecId unspec ty_maybes (no_free_tvs new_ty)) + Id u n new_ty info (SpecId unspec ty_maybes (no_free_tvs new_ty)) where new_ty = specialiseTy ty ty_maybes 0 localiseId :: Id -> Id -localiseId id@(Id u ty info details) - = Id u ty info (LocalId (mkShortName name loc) (no_free_tvs ty)) +localiseId id@(Id u n ty info details) + = Id u (mkShortName name loc) ty info (LocalId (no_free_tvs ty)) where name = getOccName id loc = getSrcLoc id @@ -1254,8 +1172,8 @@ localiseId id@(Id u ty info details) mkIdWithNewUniq :: Id -> Unique -> Id -mkIdWithNewUniq (Id _ ty details prag info) uniq - = Id uniq ty details prag info +mkIdWithNewUniq (Id _ n ty details prag info) u + = Id u (changeUnique n u) ty details prag info \end{code} Make some local @Ids@ for a template @CoreExpr@. These have bogus @@ -1273,13 +1191,13 @@ mkTemplateLocals tys getIdInfo :: GenId ty -> IdInfo getPragmaInfo :: GenId ty -> PragmaInfo -getIdInfo (Id _ _ _ _ info) = info -getPragmaInfo (Id _ _ _ info _) = info +getIdInfo (Id _ _ _ _ _ info) = info +getPragmaInfo (Id _ _ _ _ info _) = info {-LATER: replaceIdInfo :: Id -> IdInfo -> Id -replaceIdInfo (Id u ty _ details) info = Id u ty info details +replaceIdInfo (Id u n ty _ details) info = Id u n ty info details selectIdInfoForSpecId :: Id -> IdInfo selectIdInfoForSpecId unspec @@ -1300,18 +1218,18 @@ besides the code-generator need arity info!) \begin{code} getIdArity :: Id -> ArityInfo -getIdArity (Id _ _ _ _ id_info) = getInfo id_info +getIdArity (Id _ _ _ _ _ id_info) = getInfo id_info dataConArity :: DataCon -> Int -dataConArity id@(Id _ _ _ _ id_info) +dataConArity id@(Id _ _ _ _ _ id_info) = ASSERT(isDataCon id) case (arityMaybe (getInfo id_info)) of Nothing -> pprPanic "dataConArity:Nothing:" (pprId PprDebug id) Just i -> i addIdArity :: Id -> Int -> Id -addIdArity (Id u ty details pinfo info) arity - = Id u ty details pinfo (info `addInfo` (mkArityInfo arity)) +addIdArity (Id u n ty details pinfo info) arity + = Id u n ty details pinfo (info `addInfo` (mkArityInfo arity)) \end{code} %************************************************************************ @@ -1336,8 +1254,9 @@ mkDataCon n stricts fields tvs ctxt args_tys tycon -- looked at until late in the game. data_con = Id (nameUnique n) + n type_of_constructor - (DataConId n data_con_tag stricts fields tvs ctxt args_tys tycon) + (DataConId data_con_tag stricts fields tvs ctxt args_tys tycon) NoPragmaInfo datacon_info @@ -1413,7 +1332,7 @@ mkDataCon n stricts fields tvs ctxt args_tys tycon mkTupleCon :: Arity -> Id mkTupleCon arity - = Id unique ty (TupleConId n arity) NoPragmaInfo tuplecon_info + = Id unique n ty (TupleConId arity) NoPragmaInfo tuplecon_info where n = mkTupleDataConName arity unique = uniqueOf n @@ -1457,34 +1376,34 @@ fIRST_TAG = 1 -- Tags allocated from here for real constructors \begin{code} dataConTag :: DataCon -> ConTag -- will panic if not a DataCon -dataConTag (Id _ _ (DataConId _ tag _ _ _ _ _ _) _ _) = tag -dataConTag (Id _ _ (TupleConId _ _) _ _) = fIRST_TAG -dataConTag (Id _ _ (SpecId unspec _ _) _ _) = dataConTag unspec +dataConTag (Id _ _ _ (DataConId tag _ _ _ _ _ _) _ _) = tag +dataConTag (Id _ _ _ (TupleConId _) _ _) = fIRST_TAG +dataConTag (Id _ _ _ (SpecId unspec _ _) _ _) = dataConTag unspec dataConTyCon :: DataCon -> TyCon -- will panic if not a DataCon -dataConTyCon (Id _ _ (DataConId _ _ _ _ _ _ _ tycon) _ _) = tycon -dataConTyCon (Id _ _ (TupleConId _ a) _ _) = mkTupleTyCon a +dataConTyCon (Id _ _ _ (DataConId _ _ _ _ _ _ tycon) _ _) = tycon +dataConTyCon (Id _ _ _ (TupleConId a) _ _) = mkTupleTyCon a dataConSig :: DataCon -> ([TyVar], ThetaType, [TauType], TyCon) -- will panic if not a DataCon -dataConSig (Id _ _ (DataConId _ _ _ _ tyvars theta_ty arg_tys tycon) _ _) +dataConSig (Id _ _ _ (DataConId _ _ _ tyvars theta_ty arg_tys tycon) _ _) = (tyvars, theta_ty, arg_tys, tycon) -dataConSig (Id _ _ (TupleConId _ arity) _ _) +dataConSig (Id _ _ _ (TupleConId arity) _ _) = (tyvars, [], tyvar_tys, mkTupleTyCon arity) where tyvars = take arity alphaTyVars tyvar_tys = mkTyVarTys tyvars dataConFieldLabels :: DataCon -> [FieldLabel] -dataConFieldLabels (Id _ _ (DataConId _ _ _ fields _ _ _ _) _ _) = fields -dataConFieldLabels (Id _ _ (TupleConId _ _) _ _) = [] +dataConFieldLabels (Id _ _ _ (DataConId _ _ fields _ _ _ _) _ _) = fields +dataConFieldLabels (Id _ _ _ (TupleConId _) _ _) = [] dataConStrictMarks :: DataCon -> [StrictnessMark] -dataConStrictMarks (Id _ _ (DataConId _ _ stricts _ _ _ _ _) _ _) = stricts -dataConStrictMarks (Id _ _ (TupleConId _ arity) _ _) - = take arity (repeat NotMarkedStrict) +dataConStrictMarks (Id _ _ _ (DataConId _ stricts _ _ _ _ _) _ _) = stricts +dataConStrictMarks (Id _ _ _ (TupleConId arity) _ _) + = nOfThem arity NotMarkedStrict dataConArgTys :: DataCon -> [Type] -- Instantiated at these types @@ -1493,12 +1412,13 @@ dataConArgTys con_id inst_tys = map (instantiateTy tenv) arg_tys where (tyvars, _, arg_tys, _) = dataConSig con_id - tenv = tyvars `zipEqual` inst_tys + tenv = zipEqual "dataConArgTys" tyvars inst_tys \end{code} \begin{code} mkRecordSelId field_label selector_ty = Id (nameUnique name) + name selector_ty (RecordSelId field_label) NoPragmaInfo @@ -1507,7 +1427,7 @@ mkRecordSelId field_label selector_ty name = fieldLabelName field_label recordSelectorFieldLabel :: Id -> FieldLabel -recordSelectorFieldLabel (Id _ _ (RecordSelId lbl) _ _) = lbl +recordSelectorFieldLabel (Id _ _ _ (RecordSelId lbl) _ _) = lbl \end{code} @@ -1547,11 +1467,11 @@ present.) \begin{code} getIdUnfolding :: Id -> UnfoldingDetails -getIdUnfolding (Id _ _ _ _ info) = getInfo_UF info +getIdUnfolding (Id _ _ _ _ _ info) = getInfo_UF info {-LATER: addIdUnfolding :: Id -> UnfoldingDetails -> Id -addIdUnfolding id@(Id u ty info details) unfold_details +addIdUnfolding id@(Id u n ty info details) unfold_details = ASSERT( case (isLocallyDefined id, unfold_details) of (_, NoUnfoldingDetails) -> True @@ -1560,7 +1480,7 @@ addIdUnfolding id@(Id u ty info details) unfold_details (False, _) -> True _ -> False -- v bad ) - Id u ty (info `addInfo_UF` unfold_details) details + Id u n ty (info `addInfo_UF` unfold_details) details -} \end{code} @@ -1583,52 +1503,52 @@ class Foo a { op :: Complex b => c -> b -> a } \begin{code} getIdDemandInfo :: Id -> DemandInfo -getIdDemandInfo (Id _ _ _ _ info) = getInfo info +getIdDemandInfo (Id _ _ _ _ _ info) = getInfo info addIdDemandInfo :: Id -> DemandInfo -> Id -addIdDemandInfo (Id u ty details prags info) demand_info - = Id u ty details prags (info `addInfo` demand_info) +addIdDemandInfo (Id u n ty details prags info) demand_info + = Id u n ty details prags (info `addInfo` demand_info) \end{code} \begin{code} getIdUpdateInfo :: Id -> UpdateInfo -getIdUpdateInfo (Id _ _ _ _ info) = getInfo info +getIdUpdateInfo (Id _ _ _ _ _ info) = getInfo info addIdUpdateInfo :: Id -> UpdateInfo -> Id -addIdUpdateInfo (Id u ty details prags info) upd_info - = Id u ty details prags (info `addInfo` upd_info) +addIdUpdateInfo (Id u n ty details prags info) upd_info + = Id u n ty details prags (info `addInfo` upd_info) \end{code} \begin{code} {- LATER: getIdArgUsageInfo :: Id -> ArgUsageInfo -getIdArgUsageInfo (Id u ty info details) = getInfo info +getIdArgUsageInfo (Id u n ty info details) = getInfo info addIdArgUsageInfo :: Id -> ArgUsageInfo -> Id -addIdArgUsageInfo (Id u ty info details) au_info - = Id u ty (info `addInfo` au_info) details +addIdArgUsageInfo (Id u n ty info details) au_info + = Id u n ty (info `addInfo` au_info) details -} \end{code} \begin{code} {- LATER: getIdFBTypeInfo :: Id -> FBTypeInfo -getIdFBTypeInfo (Id u ty info details) = getInfo info +getIdFBTypeInfo (Id u n ty info details) = getInfo info addIdFBTypeInfo :: Id -> FBTypeInfo -> Id -addIdFBTypeInfo (Id u ty info details) upd_info - = Id u ty (info `addInfo` upd_info) details +addIdFBTypeInfo (Id u n ty info details) upd_info + = Id u n ty (info `addInfo` upd_info) details -} \end{code} \begin{code} {- LATER: getIdSpecialisation :: Id -> SpecEnv -getIdSpecialisation (Id _ _ _ _ info) = getInfo info +getIdSpecialisation (Id _ _ _ _ _ info) = getInfo info addIdSpecialisation :: Id -> SpecEnv -> Id -addIdSpecialisation (Id u ty details prags info) spec_info - = Id u ty details prags (info `addInfo` spec_info) +addIdSpecialisation (Id u n ty details prags info) spec_info + = Id u n ty details prags (info `addInfo` spec_info) -} \end{code} @@ -1637,12 +1557,12 @@ Strictness: we snaffle the info out of the IdInfo. \begin{code} getIdStrictness :: Id -> StrictnessInfo -getIdStrictness (Id _ _ _ _ info) = getInfo info +getIdStrictness (Id _ _ _ _ _ info) = getInfo info addIdStrictness :: Id -> StrictnessInfo -> Id -addIdStrictness (Id u ty details prags info) strict_info - = Id u ty details prags (info `addInfo` strict_info) +addIdStrictness (Id u n ty details prags info) strict_info + = Id u n ty details prags (info `addInfo` strict_info) \end{code} %************************************************************************ @@ -1654,7 +1574,7 @@ addIdStrictness (Id u ty details prags info) strict_info Comparison: equality and ordering---this stuff gets {\em hammered}. \begin{code} -cmpId (Id u1 _ _ _ _) (Id u2 _ _ _ _) = cmp u1 u2 +cmpId (Id u1 _ _ _ _ _) (Id u2 _ _ _ _ _) = cmp u1 u2 -- short and very sweet \end{code} @@ -1692,12 +1612,12 @@ cmpId_withSpecDataCon id1 id2 cmp_ids = cmpId id1 id2 eq_ids = case cmp_ids of { EQ_ -> True; other -> False } -cmpEqDataCon (Id _ _ (SpecId _ mtys1 _) _ _) (Id _ _ (SpecId _ mtys2 _) _ _) +cmpEqDataCon (Id _ _ _ (SpecId _ mtys1 _) _ _) (Id _ _ _ (SpecId _ mtys2 _) _ _) = panic# "Id.cmpEqDataCon:cmpUniTypeMaybeList mtys1 mtys2" -cmpEqDataCon _ (Id _ _ (SpecId _ _ _) _ _) = LT_ -cmpEqDataCon (Id _ _ (SpecId _ _ _) _ _) _ = GT_ -cmpEqDataCon _ _ = EQ_ +cmpEqDataCon _ (Id _ _ _ (SpecId _ _ _) _ _) = LT_ +cmpEqDataCon (Id _ _ _ (SpecId _ _ _) _ _) _ = GT_ +cmpEqDataCon _ _ = EQ_ \end{code} %************************************************************************ @@ -1739,82 +1659,33 @@ Default printing code (not used for interfaces): \begin{code} pprId :: Outputable ty => PprStyle -> GenId ty -> Pretty -pprId other_sty id - = let - pieces = getIdNamePieces (case other_sty of {PprForUser -> False; _ -> True}) id - - for_code - = let - pieces_to_print -- maybe use Unique only - = if isSysLocalId id then tail pieces else pieces - in - ppIntersperse (ppPStr cSEP) (map identToC pieces_to_print) - in - case other_sty of - PprForC -> for_code - PprForAsm _ _ -> for_code - PprInterface -> ppr other_sty occur_name - PprForUser -> ppr other_sty occur_name - PprUnfolding -> qualified_name pieces - PprDebug -> qualified_name pieces - PprShowAll -> ppBesides [qualified_name pieces, - (ppCat [pp_uniq id, - ppPStr SLIT("{-"), - ppr other_sty (idType id), - ppIdInfo other_sty (unsafeGenId2Id id) True - (\x->x) nullIdEnv (getIdInfo id), - ppPStr SLIT("-}") ])] - where - occur_name = getOccName id `appendRdr` - (if not (isSysLocalId id) - then SLIT("") - else SLIT(".") _APPEND_ (showUnique (idUnique id))) - - qualified_name pieces - = ppBeside (pp_ubxd (ppIntersperse (ppChar '.') (map ppPStr pieces))) (pp_uniq id) - - pp_uniq (Id _ _ (PreludeId _) _ _) = ppNil -- no uniq to add - pp_uniq (Id _ _ (DataConId _ _ _ _ _ _ _ _) _ _) = ppNil - pp_uniq (Id _ _ (TupleConId _ _) _ _) = ppNil - pp_uniq (Id _ _ (LocalId _ _) _ _) = ppNil -- uniq printed elsewhere - pp_uniq (Id _ _ (SysLocalId _ _) _ _) = ppNil - pp_uniq (Id _ _ (SpecPragmaId _ _ _) _ _) = ppNil - pp_uniq (Id _ _ (InstId _ _) _ _) = ppNil - pp_uniq other_id = ppBesides [ppPStr SLIT("{-"), pprUnique (idUnique other_id), ppPStr SLIT("-}")] - - -- print PprDebug Ids with # afterwards if they are of primitive type. - pp_ubxd pretty = pretty - -{- LATER: applying isPrimType restricts type - pp_ubxd pretty = if isPrimType (idType id) - then ppBeside pretty (ppChar '#') - else pretty --} - +pprId sty (Id u n _ _ _ _) = ppr sty n + -- WDP 96/05/06: We can re-elaborate this as we go along... \end{code} \begin{code} -idUnique (Id u _ _ _ _) = u +idUnique (Id u _ _ _ _ _) = u instance Uniquable (GenId ty) where uniqueOf = idUnique instance NamedThing (GenId ty) where - getName this_id@(Id u _ details _ _) + getName this_id@(Id u n _ details _ _) = n +{- OLD: = get details where - get (LocalId n _) = n - get (SysLocalId n _) = n - get (SpecPragmaId n _ _) = n - get (ImportedId n) = n - get (PreludeId n) = n - get (TopLevId n) = n + get (LocalId _) = n + get (SysLocalId _) = n + get (SpecPragmaId _ _) = n + get ImportedId = n + get PreludeId = n + get TopLevId = n get (InstId n _) = n - get (DataConId n _ _ _ _ _ _ _) = n - get (TupleConId n _) = n + get (DataConId _ _ _ _ _ _ _) = n + get (TupleConId _) = n get (RecordSelId l) = getName l get _ = mkCompoundName u (getIdNamePieces False{-no Uniques-} this_id) - +-} {- LATER: get (MethodSelId c op) = case (moduleOf (origName c)) of -- ToDo; better ??? mod -> (mod, classOpString op) @@ -1939,7 +1810,7 @@ mkIdSet = mkUniqSet \begin{code} addId, nmbrId :: Id -> NmbrM Id -addId id@(Id u ty det prag info) nenv@(NmbrEnv ui ut uu idenv tvenv uvenv) +addId id@(Id u n ty det prag info) nenv@(NmbrEnv ui ut uu idenv tvenv uvenv) = case (lookupUFM_Directly idenv u) of Just xx -> _trace "addId: already in map!" $ (nenv, xx) @@ -1958,11 +1829,11 @@ addId id@(Id u ty det prag info) nenv@(NmbrEnv ui ut uu idenv tvenv uvenv) (nenv2, new_ty) = nmbrType ty nenv_plus_id (nenv3, new_det) = nmbr_details det nenv2 - new_id = Id ui new_ty new_det prag info + new_id = Id ui n new_ty new_det prag info in (nenv3, new_id) -nmbrId id@(Id u ty det prag info) nenv@(NmbrEnv ui ut uu idenv tvenv uvenv) +nmbrId id@(Id u n ty det prag info) nenv@(NmbrEnv ui ut uu idenv tvenv uvenv) = case (lookupUFM_Directly idenv u) of Just xx -> (nenv, xx) Nothing -> @@ -1974,19 +1845,19 @@ nmbrId id@(Id u ty det prag info) nenv@(NmbrEnv ui ut uu idenv tvenv uvenv) (nenv2, new_ty) = nmbrType ty nenv (nenv3, new_det) = nmbr_details det nenv2 - new_id = Id u new_ty new_det prag info + new_id = Id u n new_ty new_det prag info in (nenv3, new_id) ------------ nmbr_details :: IdDetails -> NmbrM IdDetails -nmbr_details (DataConId n tag marks fields tvs theta arg_tys tc) +nmbr_details (DataConId tag marks fields tvs theta arg_tys tc) = mapNmbr nmbrTyVar tvs `thenNmbr` \ new_tvs -> mapNmbr nmbrField fields `thenNmbr` \ new_fields -> mapNmbr nmbr_theta theta `thenNmbr` \ new_theta -> mapNmbr nmbrType arg_tys `thenNmbr` \ new_arg_tys -> - returnNmbr (DataConId n tag marks new_fields new_tvs new_theta new_arg_tys tc) + returnNmbr (DataConId tag marks new_fields new_tvs new_theta new_arg_tys tc) where nmbr_theta (c,t) = --nmbrClass c `thenNmbr` \ new_c -> diff --git a/ghc/compiler/basicTypes/IdInfo.lhs b/ghc/compiler/basicTypes/IdInfo.lhs index 90f81a8..4d2a2a1 100644 --- a/ghc/compiler/basicTypes/IdInfo.lhs +++ b/ghc/compiler/basicTypes/IdInfo.lhs @@ -81,11 +81,10 @@ import Outputable ( ifPprInterface, Outputable(..){-instances-} ) import PprStyle ( PprStyle(..) ) import Pretty import SrcLoc ( mkUnknownSrcLoc ) -import Type ( eqSimpleTy ) +import Type ( eqSimpleTy, splitFunTyExpandingDicts ) import Util ( mapAccumL, panic, assertPanic, pprPanic ) applySubstToTy = panic "IdInfo.applySubstToTy" -splitTypeWithDictsAsArgs = panic "IdInfo.splitTypeWithDictsAsArgs" showTypeCategory = panic "IdInfo.showTypeCategory" mkFormSummary = panic "IdInfo.mkFormSummary" occurAnalyseGlobalExpr = panic "IdInfo.occurAnalyseGlobalExpr" @@ -583,9 +582,8 @@ mkWrapperArgTypeCategories -> String -- a string saying lots about the args mkWrapperArgTypeCategories wrapper_ty wrap_info - = case (splitTypeWithDictsAsArgs wrapper_ty) of { (_,arg_tys,_) -> - map do_one (wrap_info `zip` (map showTypeCategory arg_tys)) - } + = case (splitFunTyExpandingDicts wrapper_ty) of { (arg_tys,_) -> + map do_one (wrap_info `zip` (map showTypeCategory arg_tys)) } where -- ToDo: this needs FIXING UP (it was a hack anyway...) do_one (WwPrim, _) = 'P' diff --git a/ghc/compiler/basicTypes/Name.lhs b/ghc/compiler/basicTypes/Name.lhs index fcb4ecf..29c1667 100644 --- a/ghc/compiler/basicTypes/Name.lhs +++ b/ghc/compiler/basicTypes/Name.lhs @@ -12,7 +12,7 @@ module Name ( RdrName(..), isUnqual, isQual, - isRdrLexCon, + isRdrLexCon, isRdrLexConOrSpecial, appendRdr, showRdr, cmpRdr, @@ -22,7 +22,7 @@ module Name ( mkLocalName, isLocalName, mkTopLevName, mkImportedName, mkImplicitName, isImplicitName, - mkBuiltinName, mkCompoundName, + mkBuiltinName, mkCompoundName, mkCompoundName2, mkFunTyConName, mkTupleDataConName, mkTupleTyConName, mkTupNameStr, @@ -31,7 +31,7 @@ module Name ( ExportFlag(..), isExported{-overloaded-}, exportFlagOn{-not-}, - nameUnique, + nameUnique, changeUnique, nameOccName, nameOrigName, nameExportFlag, @@ -88,6 +88,9 @@ isQual (Qual _ _) = True isRdrLexCon (Unqual n) = isLexCon n isRdrLexCon (Qual m n) = isLexCon n +isRdrLexConOrSpecial (Unqual n) = isLexCon n || isLexSpecialSym n +isRdrLexConOrSpecial (Qual m n) = isLexCon n || isLexSpecialSym n + appendRdr (Unqual n) str = Unqual (n _APPEND_ str) appendRdr (Qual m n) str = ASSERT(not (fromPrelude m)) Qual m (n _APPEND_ str) @@ -95,7 +98,7 @@ appendRdr (Qual m n) str = ASSERT(not (fromPrelude m)) cmpRdr (Unqual n1) (Unqual n2) = _CMP_STRING_ n1 n2 cmpRdr (Unqual n1) (Qual m2 n2) = LT_ cmpRdr (Qual m1 n1) (Unqual n2) = GT_ -cmpRdr (Qual m1 n1) (Qual m2 n2) = thenCmp (_CMP_STRING_ m1 m2) (_CMP_STRING_ n1 n2) +cmpRdr (Qual m1 n1) (Qual m2 n2) = _CMP_STRING_ m1 m2 `thenCmp` _CMP_STRING_ n1 n2 instance Eq RdrName where a == b = case (a `cmp` b) of { EQ_ -> True; _ -> False } @@ -174,15 +177,36 @@ mkImplicitName :: Unique -> RdrName -> Name mkImplicitName u o = Global u o Implicit NotExported [] mkBuiltinName :: Unique -> Module -> FAST_STRING -> Name -mkBuiltinName u m n = Global u (Unqual n) Builtin NotExported [] - -mkCompoundName :: Unique -> [FAST_STRING] -> Name -mkCompoundName u ns - = Global u (Unqual{-???-} (_CONCAT_ (dotify ns))) Builtin{--} NotExported [] - where - dotify [] = [] - dotify [n] = [n] - dotify (n:ns) = n : (map (_CONS_ '.') ns) +mkBuiltinName u m{-NB: unused(?)-} n = Global u (Unqual n) Builtin NotExported [] + +mkCompoundName :: Unique + -> FAST_STRING -- indicates what kind of compound thing it is (e.g., "sdsel") + -> [RdrName] -- "dot" these names together + -> Name -- from which we get provenance, etc.... + -> Name -- result! + +mkCompoundName u str ns (Local _ _ _) = panic "mkCompoundName:Local?" +mkCompoundName u str ns (Global _ _ prov exp _) + = Global u (Unqual{-???-} (_CONCAT_ (glue ns [str]))) prov exp [] + +glue [] acc = reverse acc +glue (Unqual n:ns) acc = glue ns (_CONS_ '.' n : acc) +glue (Qual m n:ns) acc = glue ns (_CONS_ '.' n : _CONS_ '.' m : acc) + +-- this ugly one is used for instance-y things +mkCompoundName2 :: Unique + -> FAST_STRING -- indicates what kind of compound thing it is (e.g., "sdsel") + -> [RdrName] -- "dot" these names together + -> [FAST_STRING] -- type-name strings + -> Bool -- True <=> defined in this module + -> SrcLoc + -> Name -- result! + +mkCompoundName2 u str ns ty_strs from_here locn + = Global u (Unqual{-???-} ((_CONCAT_ (glue ns [str])) _APPEND_ (_CONS_ '.' (_CONCAT_ ty_strs)))) + (if from_here then LocalDef locn else Imported ExportAll locn []) + ExportAll{-instances-} + [] mkFunTyConName = mkBuiltinName funTyConKey pRELUDE_BUILTIN SLIT("->") @@ -261,6 +285,13 @@ instance NamedThing Name where nameUnique (Local u _ _) = u nameUnique (Global u _ _ _ _) = u +-- when we renumber/rename things, we need to be +-- able to change a Name's Unique to match the cached +-- one in the thing it's the name of. If you know what I mean. +changeUnique (Local _ n l) u = Local u n l +changeUnique n@(Global _ o p e os) u = ASSERT(not (isBuiltinName n)) + Global u o p e os + nameOrigName (Local _ n _) = Unqual n nameOrigName (Global _ orig _ _ _) = orig @@ -302,19 +333,16 @@ isPreludeDefinedName (Global _ orig _ _ _) = isUnqual orig \begin{code} instance Outputable Name where -#ifdef DEBUG - ppr PprDebug (Local u n _) = pp_debug u (ppPStr n) - ppr PprDebug (Global u o _ _ _) = pp_debug u (ppr PprDebug o) -#endif - ppr sty (Local u n _) = pp_name sty n + ppr sty (Local u n _) + | codeStyle sty = pprUnique u + | otherwise = ppBesides [pprUnique u, ppStr "{-", ppPStr n, ppStr "-}"] + + ppr PprDebug (Global u o _ _ _) = ppBesides [ppr PprDebug o, ppStr "{-", pprUnique u, ppStr "-}"] ppr PprForUser (Global u o _ _ [] ) = ppr PprForUser o ppr PprForUser (Global u o _ _ occs) = ppr PprForUser (head occs) ppr PprShowAll (Global u o prov exp occs) = pp_all o prov exp occs ppr sty (Global u o _ _ _) = ppr sty o -pp_debug uniq thing - = ppBesides [thing, ppStr "{-", pprUnique uniq, ppStr "-}" ] - pp_all orig prov exp occs = ppBesides [ppr PprShowAll orig, ppr PprShowAll occs, pp_prov prov, pp_exp exp] diff --git a/ghc/compiler/basicTypes/Unique.lhs b/ghc/compiler/basicTypes/Unique.lhs index 54c7898..4e2d732 100644 --- a/ghc/compiler/basicTypes/Unique.lhs +++ b/ghc/compiler/basicTypes/Unique.lhs @@ -49,7 +49,6 @@ module Unique ( appendIdKey, arrayPrimTyConKey, augmentIdKey, - binaryClassKey, boolTyConKey, boundedClassKey, buildDataConKey, @@ -57,6 +56,7 @@ module Unique ( byteArrayPrimTyConKey, cCallableClassKey, cReturnableClassKey, + voidTyConKey, charDataConKey, charPrimTyConKey, charTyConKey, @@ -112,6 +112,8 @@ module Unique ( mallocPtrTyConKey, monadClassKey, monadZeroClassKey, + monadPlusClassKey, + functorClassKey, mutableArrayPrimTyConKey, mutableByteArrayPrimTyConKey, nilDataConKey, @@ -416,26 +418,29 @@ getBuiltinUniques n = map (mkUnique 'B') [1 .. n] %************************************************************************ \begin{code} -eqClassKey = mkPreludeClassUnique 1 -ordClassKey = mkPreludeClassUnique 2 -numClassKey = mkPreludeClassUnique 3 -integralClassKey = mkPreludeClassUnique 4 -fractionalClassKey = mkPreludeClassUnique 5 -floatingClassKey = mkPreludeClassUnique 6 -realClassKey = mkPreludeClassUnique 7 -realFracClassKey = mkPreludeClassUnique 8 -realFloatClassKey = mkPreludeClassUnique 9 -ixClassKey = mkPreludeClassUnique 10 -enumClassKey = mkPreludeClassUnique 11 -showClassKey = mkPreludeClassUnique 12 -readClassKey = mkPreludeClassUnique 13 -monadClassKey = mkPreludeClassUnique 14 -monadZeroClassKey = mkPreludeClassUnique 15 -binaryClassKey = mkPreludeClassUnique 16 -cCallableClassKey = mkPreludeClassUnique 17 -cReturnableClassKey = mkPreludeClassUnique 18 -evalClassKey = mkPreludeClassUnique 19 -boundedClassKey = mkPreludeClassUnique 20 +boundedClassKey = mkPreludeClassUnique 1 +enumClassKey = mkPreludeClassUnique 2 +eqClassKey = mkPreludeClassUnique 3 +evalClassKey = mkPreludeClassUnique 4 +floatingClassKey = mkPreludeClassUnique 5 +fractionalClassKey = mkPreludeClassUnique 6 +integralClassKey = mkPreludeClassUnique 7 +monadClassKey = mkPreludeClassUnique 8 +monadZeroClassKey = mkPreludeClassUnique 9 +monadPlusClassKey = mkPreludeClassUnique 10 +functorClassKey = mkPreludeClassUnique 11 +numClassKey = mkPreludeClassUnique 12 +ordClassKey = mkPreludeClassUnique 13 +readClassKey = mkPreludeClassUnique 14 +realClassKey = mkPreludeClassUnique 15 +realFloatClassKey = mkPreludeClassUnique 16 +realFracClassKey = mkPreludeClassUnique 17 +showClassKey = mkPreludeClassUnique 18 + +cCallableClassKey = mkPreludeClassUnique 19 +cReturnableClassKey = mkPreludeClassUnique 20 + +ixClassKey = mkPreludeClassUnique 21 \end{code} %************************************************************************ @@ -498,6 +503,7 @@ primIoTyConKey = mkPreludeTyConUnique 51 voidPrimTyConKey = mkPreludeTyConUnique 52 wordPrimTyConKey = mkPreludeTyConUnique 53 wordTyConKey = mkPreludeTyConUnique 54 +voidTyConKey = mkPreludeTyConUnique 55 \end{code} %************************************************************************ diff --git a/ghc/compiler/codeGen/CgBindery.lhs b/ghc/compiler/codeGen/CgBindery.lhs index 534fa94..b00aca7 100644 --- a/ghc/compiler/codeGen/CgBindery.lhs +++ b/ghc/compiler/codeGen/CgBindery.lhs @@ -340,7 +340,7 @@ bindNewToLit name lit bindArgsToRegs :: [Id] -> [MagicId] -> Code bindArgsToRegs args regs - = listCs (zipWithEqual bind args regs) + = listCs (zipWithEqual "bindArgsToRegs" bind args regs) where arg `bind` reg = bindNewToReg arg reg mkLFArgument \end{code} diff --git a/ghc/compiler/codeGen/CgCase.lhs b/ghc/compiler/codeGen/CgCase.lhs index 1caec5f..85f58f1 100644 --- a/ghc/compiler/codeGen/CgCase.lhs +++ b/ghc/compiler/codeGen/CgCase.lhs @@ -61,15 +61,12 @@ import PrimRep ( getPrimRepSize, isFollowableRep, retPrimRepSize, ) import TyCon ( isEnumerationTyCon ) import Type ( typePrimRep, - getDataSpecTyCon, getDataSpecTyCon_maybe, + getAppSpecDataTyConExpandingDicts, maybeAppSpecDataTyConExpandingDicts, isEnumerationTyCon ) import Util ( sortLt, isIn, isn'tIn, zipEqual, pprError, panic, assertPanic ) - -getDataSpecTyCon = panic "CgCase.getDataSpecTyCon (ToDo)" -getDataSpecTyCon_maybe = panic "CgCase.getDataSpecTyCon_maybe (ToDo)" \end{code} \begin{code} @@ -385,7 +382,7 @@ getPrimAppResultAmodes uniq (StgAlgAlts ty alts (StgBindDefault _ True {- used - -- A temporary variable to hold the tag; this is unaffected by GC because -- the heap-checks in the branches occur after the switch tag_amode = CTemp uniq IntRep - (spec_tycon, _, _) = getDataSpecTyCon ty + (spec_tycon, _, _) = getAppSpecDataTyConExpandingDicts ty getPrimAppResultAmodes uniq (StgAlgAlts ty alts other_default) -- Default is either StgNoDefault or StgBindDefault with unused binder @@ -451,7 +448,7 @@ cgEvalAlts cc_slot uniq (StgAlgAlts ty alts deflt) -- which is worse than having the alt code in the switch statement let - (spec_tycon, _, _) = getDataSpecTyCon ty + (spec_tycon, _, _) = getAppSpecDataTyConExpandingDicts ty use_labelled_alts = case ctrlReturnConvAlg spec_tycon of @@ -588,7 +585,7 @@ cgAlgAlts gc_flag uniq restore_cc semi_tagging default_join_lbl = mkDefaultLabel uniq jump_instruction = CJump (CLbl default_join_lbl CodePtrRep) - (spec_tycon, _, spec_cons) = getDataSpecTyCon ty + (spec_tycon, _, spec_cons) = getAppSpecDataTyConExpandingDicts ty alt_cons = [ con | (con,_,_,_) <- alts ] @@ -714,7 +711,7 @@ cgAlgAltRhs gc_flag con args use_mask rhs (live_regs, node_reqd) = case (dataReturnConvAlg con) of ReturnInHeap -> ([], True) - ReturnInRegs regs -> ([reg | (reg,True) <- regs `zipEqual` use_mask], False) + ReturnInRegs regs -> ([reg | (reg,True) <- zipEqual "cgAlgAltRhs" regs use_mask], False) -- Pick the live registers using the use_mask -- Doing so is IMPORTANT, because with semi-tagging -- enabled only the live registers will have valid @@ -1053,7 +1050,7 @@ mkReturnVector uniq ty tagged_alt_absCs deflt_absC -- ) where - (spec_tycon,_,_) = case (getDataSpecTyCon_maybe ty) of -- *must* be a real "data" type constructor + (spec_tycon,_,_) = case (maybeAppSpecDataTyConExpandingDicts ty) of -- *must* be a real "data" type constructor Just xx -> xx Nothing -> pprError "ERROR: can't generate code for polymorphic case;\nprobably a mis-use of `seq' or `par';\nthe User's Guide has more details.\nOffending type: " (ppr PprDebug ty) diff --git a/ghc/compiler/codeGen/CgCon.lhs b/ghc/compiler/codeGen/CgCon.lhs index 6c378a9..0d0e620 100644 --- a/ghc/compiler/codeGen/CgCon.lhs +++ b/ghc/compiler/codeGen/CgCon.lhs @@ -50,11 +50,10 @@ import Id ( idPrimRep, dataConTag, dataConTyCon, ) import Literal ( Literal(..) ) import Maybes ( maybeToBool ) +import PrelInfo ( maybeCharLikeTyCon, maybeIntLikeTyCon ) import PrimRep ( isFloatingRep, PrimRep(..) ) +import TyCon ( TyCon{-instance Uniquable-} ) import Util ( isIn, zipWithEqual, panic, assertPanic ) - -maybeCharLikeTyCon = panic "CgCon.maybeCharLikeTyCon (ToDo)" -maybeIntLikeTyCon = panic "CgCon.maybeIntLikeTyCon (ToDo)" \end{code} %************************************************************************ @@ -438,7 +437,7 @@ cgReturnDataCon con amodes all_zero_size_args live_vars ReturnInRegs regs -> let - reg_assts = mkAbstractCs (zipWithEqual move_to_reg amodes regs) + reg_assts = mkAbstractCs (zipWithEqual "move_to_reg" move_to_reg amodes regs) info_lbl = mkPhantomInfoTableLabel con in profCtrC SLIT("RET_NEW_IN_REGS") [mkIntCLit (length amodes)] `thenC` diff --git a/ghc/compiler/codeGen/CgConTbls.lhs b/ghc/compiler/codeGen/CgConTbls.lhs index c35219e..29a89a5 100644 --- a/ghc/compiler/codeGen/CgConTbls.lhs +++ b/ghc/compiler/codeGen/CgConTbls.lhs @@ -41,12 +41,12 @@ import Id ( dataConTag, dataConSig, GenId{-instance NamedThing-} ) import Name ( getLocalName ) +import PrelInfo ( maybeIntLikeTyCon ) import PrimRep ( getPrimRepSize, PrimRep(..) ) import TyCon ( tyConDataCons, mkSpecTyCon ) import Type ( typePrimRep ) import Util ( panic ) -maybeIntLikeTyCon = panic "CgConTbls.maybeIntLikeTyCon (ToDo)" mkSameSpecCon = panic "CgConTbls.mkSameSpecCon (ToDo)" \end{code} diff --git a/ghc/compiler/codeGen/CgRetConv.lhs b/ghc/compiler/codeGen/CgRetConv.lhs index f1a35f6..856a119 100644 --- a/ghc/compiler/codeGen/CgRetConv.lhs +++ b/ghc/compiler/codeGen/CgRetConv.lhs @@ -235,7 +235,7 @@ makePrimOpArgsRobust op arg_amodes other -> pprError "Cannot allocate enough registers for primop (try rearranging code or reducing number of arguments?)" (ppr PprDebug op) arg_assts - = mkAbstractCs (zipWithEqual assign_to_reg final_arg_regs non_robust_amodes) + = mkAbstractCs (zipWithEqual "assign_to_reg" assign_to_reg final_arg_regs non_robust_amodes) assign_to_reg reg_id amode = CAssign (CReg reg_id) amode diff --git a/ghc/compiler/codeGen/CgTailCall.lhs b/ghc/compiler/codeGen/CgTailCall.lhs index 560adde..8b3c23e 100644 --- a/ghc/compiler/codeGen/CgTailCall.lhs +++ b/ghc/compiler/codeGen/CgTailCall.lhs @@ -353,10 +353,11 @@ tailCallBusiness fun fun_amode lf_info arg_amodes live_vars pending_assts no_of_args = length arg_amodes - (reg_arg_assts, stk_arg_amodes) - = (mkAbstractCs (zipWithEqual assign_to_reg arg_regs arg_amodes), - drop (length arg_regs) arg_amodes) -- No regs, or - -- args beyond arity + (reg_arg_amodes, stk_arg_amodes) = splitAt (length arg_regs) arg_amodes + -- We get some stk_arg_amodes if (a) no regs, or (b) args beyond arity + + reg_arg_assts + = mkAbstractCs (zipWithEqual "assign_to_reg2" assign_to_reg arg_regs reg_arg_amodes) assign_to_reg reg_id amode = CAssign (CReg reg_id) amode in diff --git a/ghc/compiler/codeGen/ClosureInfo.lhs b/ghc/compiler/codeGen/ClosureInfo.lhs index 9e08f64..e45fdec 100644 --- a/ghc/compiler/codeGen/ClosureInfo.lhs +++ b/ghc/compiler/codeGen/ClosureInfo.lhs @@ -89,15 +89,15 @@ import Maybes ( assocMaybe, maybeToBool ) import Name ( isLocallyDefined, getLocalName ) import PprStyle ( PprStyle(..) ) import PprType ( GenType{-instance Outputable-} ) +import PrelInfo ( maybeCharLikeTyCon, maybeIntLikeTyCon ) import PrimRep ( getPrimRepSize, separateByPtrFollowness ) import SMRep -- all of it import TyCon ( maybeTyConSingleCon, TyCon{-instance NamedThing-} ) -import Type ( isPrimType, splitForAllTy, splitFunTyWithDictsAsArgs, mkFunTys ) +import Type ( isPrimType, splitForAllTy, splitFunTyExpandingDicts, + mkFunTys, maybeAppSpecDataTyConExpandingDicts + ) import Util ( isIn, mapAccumL, panic, pprPanic, assertPanic ) -maybeCharLikeTyCon = panic "ClosureInfo.maybeCharLikeTyCon (ToDo)" -maybeIntLikeTyCon = panic "ClosureInfo.maybeIntLikeTyCon (ToDo)" -getDataSpecTyCon_maybe = panic "ClosureInfo.getDataSpecTyCon_maybe (ToDo)" getTyDescription = panic "ClosureInfo.getTyDescription (ToDo)" \end{code} @@ -1136,9 +1136,9 @@ closureType :: ClosureInfo -> Maybe (TyCon, [Type], [Id]) -- rather than take it from the Id. The Id is probably just "f"! closureType (MkClosureInfo id (LFThunk _ _ _ (VapThunk fun_id args _)) _) - = getDataSpecTyCon_maybe (fun_result_ty (length args) fun_id) + = maybeAppSpecDataTyConExpandingDicts (fun_result_ty (length args) fun_id) -closureType (MkClosureInfo id lf _) = getDataSpecTyCon_maybe (idType id) +closureType (MkClosureInfo id lf _) = maybeAppSpecDataTyConExpandingDicts (idType id) \end{code} @closureReturnsUnboxedType@ is used to check whether a closure, {\em @@ -1163,7 +1163,7 @@ closureReturnsUnboxedType other_closure = False fun_result_ty arity id = let (_, de_foralld_ty) = splitForAllTy (idType id) - (arg_tys, res_ty) = splitFunTyWithDictsAsArgs de_foralld_ty + (arg_tys, res_ty) = splitFunTyExpandingDicts de_foralld_ty in ASSERT(arity >= 0 && length arg_tys >= arity) mkFunTys (drop arity arg_tys) res_ty diff --git a/ghc/compiler/coreSyn/CoreLift.lhs b/ghc/compiler/coreSyn/CoreLift.lhs index 381c500..6719a80 100644 --- a/ghc/compiler/coreSyn/CoreLift.lhs +++ b/ghc/compiler/coreSyn/CoreLift.lhs @@ -28,7 +28,7 @@ import Id ( idType, mkSysLocal, import Name ( isLocallyDefined, getSrcLoc ) import PrelInfo ( liftDataCon, mkLiftTy, statePrimTyCon ) import TyCon ( isBoxedTyCon, TyCon{-instance-} ) -import Type ( maybeAppDataTyCon, eqTy ) +import Type ( maybeAppDataTyConExpandingDicts, eqTy ) import UniqSupply ( getUnique, getUniques, splitUniqSupply, UniqSupply ) import Util ( zipEqual, zipWithEqual, assertPanic, panic ) @@ -261,7 +261,7 @@ liftBinders top_lev bind liftM idenv s0 (s1, s2) = splitUniqSupply s0 lift_ids = [ id | id <- bindersOf bind, isUnboxedButNotState (idType id) ] lift_uniqs = getUniques (length lift_ids) s1 - lift_map = zipEqual lift_ids (zipWithEqual mkLiftedId lift_ids lift_uniqs) + lift_map = zipEqual "liftBinders" lift_ids (zipWithEqual "liftBinders" mkLiftedId lift_ids lift_uniqs) -- ToDo: Give warning for recursive bindings involving unboxed values ??? @@ -312,7 +312,7 @@ applyBindUnlifts [] expr = expr applyBindUnlifts (f:fs) expr = f (applyBindUnlifts fs expr) isUnboxedButNotState ty - = case (maybeAppDataTyCon ty) of + = case (maybeAppDataTyConExpandingDicts ty) of Nothing -> False Just (tycon, _, _) -> not (isBoxedTyCon tycon) && not (tycon == statePrimTyCon) diff --git a/ghc/compiler/coreSyn/CoreLint.lhs b/ghc/compiler/coreSyn/CoreLint.lhs index e2c8269..f30e5e7 100644 --- a/ghc/compiler/coreSyn/CoreLint.lhs +++ b/ghc/compiler/coreSyn/CoreLint.lhs @@ -1,5 +1,5 @@ % -% (c) The GRASP/AQUA Project, Glasgow University, 1993-1995 +% (c) The GRASP/AQUA Project, Glasgow University, 1993-1996 % \section[CoreLint]{A ``lint'' pass to check for Core correctness} @@ -31,10 +31,12 @@ import Pretty import PrimOp ( primOpType, PrimOp(..) ) import PrimRep ( PrimRep(..) ) import SrcLoc ( SrcLoc ) -import Type ( mkFunTy,getFunTy_maybe,mkForAllTy,getForAllTy_maybe, - isPrimType,typeKind,instantiateTy, +import Type ( mkFunTy,getFunTy_maybe,mkForAllTy,mkForAllTys,getForAllTy_maybe, + getFunTyExpandingDicts_maybe, + isPrimType,typeKind,instantiateTy,splitSigmaTy, mkForAllUsageTy,getForAllUsageTy,instantiateUsage, - maybeAppDataTyCon, eqTy + maybeAppDataTyConExpandingDicts, eqTy +-- ,expandTy -- ToDo:rm ) import TyCon ( isPrimTyCon, tyConFamilySize ) import TyVar ( tyVarKind, GenTyVar{-instances-} ) @@ -197,19 +199,25 @@ lintCoreExpr (Let binds body) (addInScopeVars binders (lintCoreExpr body)) lintCoreExpr e@(Con con args) - = lintCoreArgs False e (idType con) args + = lintCoreArgs {-False-} e unoverloaded_ty args -- Note: we don't check for primitive types in these arguments + where + -- Constructors are special in that they aren't passed their + -- dictionary arguments, so we swizzle them out of the + -- constructor type before handing over to lintCorArgs + unoverloaded_ty = mkForAllTys tyvars tau + (tyvars, theta, tau) = splitSigmaTy (idType con) lintCoreExpr e@(Prim op args) - = lintCoreArgs True e (primOpType op) args + = lintCoreArgs {-True-} e (primOpType op) args -- Note: we do check for primitive types in these arguments lintCoreExpr e@(App fun@(Var v) arg) | isBottomingId v - = lintCoreExpr fun `thenMaybeL` \ ty -> lintCoreArg False e ty arg + = lintCoreExpr fun `thenMaybeL` \ ty -> lintCoreArg {-False-} e ty arg -- Note: we don't check for primitive types in argument to 'error' lintCoreExpr e@(App fun arg) - = lintCoreExpr fun `thenMaybeL` \ty -> lintCoreArg True e ty arg + = lintCoreExpr fun `thenMaybeL` \ty -> lintCoreArg {-True-} e ty arg -- Note: we do check for primitive types in this argument lintCoreExpr (Lam (ValBinder var) expr) @@ -238,12 +246,12 @@ The boolean argument indicates whether we should flag type applications to primitive types as being errors. \begin{code} -lintCoreArgs :: Bool -> CoreExpr -> Type -> [CoreArg] -> LintM (Maybe Type) +lintCoreArgs :: {-Bool ->-} CoreExpr -> Type -> [CoreArg] -> LintM (Maybe Type) -lintCoreArgs _ _ ty [] = returnL (Just ty) -lintCoreArgs checkTyApp e ty (a : args) - = lintCoreArg checkTyApp e ty a `thenMaybeL` \ res -> - lintCoreArgs checkTyApp e res args +lintCoreArgs _ ty [] = returnL (Just ty) +lintCoreArgs e ty (a : args) + = lintCoreArg e ty a `thenMaybeL` \ res -> + lintCoreArgs e res args \end{code} %************************************************************************ @@ -253,23 +261,27 @@ lintCoreArgs checkTyApp e ty (a : args) %************************************************************************ \begin{code} -lintCoreArg :: Bool -> CoreExpr -> Type -> CoreArg -> LintM (Maybe Type) +lintCoreArg :: {-Bool ->-} CoreExpr -> Type -> CoreArg -> LintM (Maybe Type) -lintCoreArg _ e ty (LitArg lit) +lintCoreArg e ty (LitArg lit) = -- Make sure function type matches argument - case (getFunTy_maybe ty) of - Just (arg,res) | (literalType lit `eqTy` arg) -> returnL(Just res) - _ -> addErrL (mkAppMsg ty (literalType lit) e) `seqL` returnL Nothing + case (getFunTyExpandingDicts_maybe ty) of + Just (arg,res) | (lit_ty `eqTy` arg) -> returnL(Just res) + _ -> addErrL (mkAppMsg ty lit_ty e) `seqL` returnL Nothing + where + lit_ty = literalType lit -lintCoreArg _ e ty (VarArg v) +lintCoreArg e ty (VarArg v) = -- Make sure variable is bound checkInScope v `seqL` -- Make sure function type matches argument - case (getFunTy_maybe ty) of - Just (arg,res) | (idType v `eqTy` arg) -> returnL(Just res) - _ -> addErrL (mkAppMsg ty (idType v) e) `seqL` returnL Nothing + case (getFunTyExpandingDicts_maybe ty) of + Just (arg,res) | (var_ty `eqTy` arg) -> returnL(Just res) + _ -> addErrL (mkAppMsg ty var_ty e) `seqL` returnL Nothing + where + var_ty = idType v -lintCoreArg checkTyApp e ty a@(TyArg arg_ty) +lintCoreArg e ty a@(TyArg arg_ty) = -- ToDo: Check that ty is well-kinded and has no unbound tyvars checkIfSpecDoneL (not (isPrimType arg_ty)) (mkSpecTyAppMsg a) `seqL` @@ -290,7 +302,7 @@ lintCoreArg checkTyApp e ty a@(TyArg arg_ty) pprTrace "lintCoreArg:kinds:" (ppCat [ppr PprDebug tyvar_kind, ppr PprDebug argty_kind]) $ addErrL (mkTyAppMsg SLIT("Kinds not right in") ty arg_ty e) `seqL` returnL Nothing -lintCoreArg _ e ty (UsageArg u) +lintCoreArg e ty (UsageArg u) = -- ToDo: Check that usage has no unbound usage variables case (getForAllUsageTy ty) of Just (uvar,bounds,body) -> @@ -350,7 +362,7 @@ lintCoreAlts whole_alts@(PrimAlts alts deflt) ty --tycon check ty = checkTys first_ty ty (mkCaseAltMsg whole_alts) lintAlgAlt scrut_ty {-tycon-ToDo: use it!-} (con,args,rhs) - = (case maybeAppDataTyCon scrut_ty of + = (case maybeAppDataTyConExpandingDicts scrut_ty of Nothing -> addErrL (mkAlgAltMsg1 scrut_ty) Just (tycon, tys_applied, cons) -> @@ -360,7 +372,7 @@ lintAlgAlt scrut_ty {-tycon-ToDo: use it!-} (con,args,rhs) checkL (con `elem` cons) (mkAlgAltMsg2 scrut_ty con) `seqL` checkL (length arg_tys == length args) (mkAlgAltMsg3 con args) `seqL` - mapL check (arg_tys `zipEqual` args) `seqL` + mapL check (zipEqual "lintAlgAlt" arg_tys args) `seqL` returnL () ) `seqL` addInScopeVars args ( @@ -575,7 +587,7 @@ mkDefltMsg deflt sty mkAppMsg :: Type -> Type -> CoreExpr -> ErrMsg mkAppMsg fun arg expr sty - = ppAboves [ppStr "Argument values doesn't match argument type:", + = ppAboves [ppStr "Argument value doesn't match argument type:", ppHang (ppStr "Fun type:") 4 (ppr sty fun), ppHang (ppStr "Arg type:") 4 (ppr sty arg), ppHang (ppStr "Expression:") 4 (pp_expr sty expr)] @@ -598,6 +610,7 @@ mkAlgAltMsg1 :: Type -> ErrMsg mkAlgAltMsg1 ty sty = ppAbove (ppStr "In some case statement, type of scrutinee is not a data type:") (ppr sty ty) +-- (ppAbove (ppr sty ty) (ppr sty (expandTy ty))) -- ToDo: rm mkAlgAltMsg2 :: Type -> Id -> ErrMsg mkAlgAltMsg2 ty con sty diff --git a/ghc/compiler/coreSyn/CoreUnfold.lhs b/ghc/compiler/coreSyn/CoreUnfold.lhs index 3989305..fe034d6 100644 --- a/ghc/compiler/coreSyn/CoreUnfold.lhs +++ b/ghc/compiler/coreSyn/CoreUnfold.lhs @@ -47,7 +47,7 @@ import Literal ( isNoRepLit, isLitLitLit ) import Pretty import PrimOp ( primOpCanTriggerGC, PrimOp(..) ) import TyCon ( tyConFamilySize ) -import Type ( getAppDataTyCon ) +import Type ( getAppDataTyConExpandingDicts ) import UniqSet ( emptyUniqSet, unitUniqSet, mkUniqSet, addOneToUniqSet, unionUniqSets ) @@ -342,7 +342,7 @@ sizeExpr scc_s_OK bOMB_OUT_SIZE args expr size_alg_alt (con,args,rhs) = size_up rhs -- Don't charge for args, so that wrappers look cheap - (tycon, _, _) = _trace "getAppDataTyCon.CoreUnfold" $ getAppDataTyCon scrut_ty + (tycon, _, _) = _trace "CoreUnfold.getAppDataTyConExpandingDicts" $ getAppDataTyConExpandingDicts scrut_ty size_up_alts _ (PrimAlts alts deflt) = foldr (addSize . size_prim_alt) (size_up_deflt deflt) alts diff --git a/ghc/compiler/coreSyn/CoreUtils.lhs b/ghc/compiler/coreSyn/CoreUtils.lhs index 3721baa..c282c70 100644 --- a/ghc/compiler/coreSyn/CoreUtils.lhs +++ b/ghc/compiler/coreSyn/CoreUtils.lhs @@ -671,7 +671,7 @@ do_CoreBinding venv tenv (Rec binds) let new_venv = growIdEnvList venv new_maps in mapUs (do_CoreExpr new_venv tenv) rhss `thenUs` \ new_rhss -> - returnUs (Rec (new_binders `zipEqual` new_rhss), new_venv) + returnUs (Rec (zipEqual "do_CoreBinding" new_binders new_rhss), new_venv) where (binders, rhss) = unzip binds \end{code} diff --git a/ghc/compiler/coreSyn/PprCore.lhs b/ghc/compiler/coreSyn/PprCore.lhs index 20f0b4d..8fa61e5 100644 --- a/ghc/compiler/coreSyn/PprCore.lhs +++ b/ghc/compiler/coreSyn/PprCore.lhs @@ -35,7 +35,7 @@ import Literal ( Literal{-instances-} ) import Name ( isSymLexeme ) import Outputable -- quite a few things import PprEnv -import PprType ( GenType{-instances-}, GenTyVar{-instance-} ) +import PprType ( pprParendGenType, GenType{-instances-}, GenTyVar{-instance-} ) import PprStyle ( PprStyle(..) ) import Pretty import PrimOp ( PrimOp{-instances-} ) @@ -91,7 +91,7 @@ init_ppr_env sty pbdr1 pbdr2 pocc (Just (ppr sty)) -- tyvars (Just (ppr sty)) -- usage vars (Just pbdr1) (Just pbdr2) (Just pocc) -- value vars - (Just (ppr sty)) -- types + (Just (pprParendGenType sty)) -- types (Just (ppr sty)) -- usages -------------- diff --git a/ghc/compiler/deSugar/DsBinds.lhs b/ghc/compiler/deSugar/DsBinds.lhs index a4d6dda..bc5bc9a 100644 --- a/ghc/compiler/deSugar/DsBinds.lhs +++ b/ghc/compiler/deSugar/DsBinds.lhs @@ -547,7 +547,7 @@ dsMonoBinds is_rec tyvars [] binder_subst (PatMonoBind pat grhss_and_binds locn) -- we can just use the rhs directly else -} - pprTrace "dsMonoBinds:PatMonoBind:" (ppr PprDebug body_expr) $ +-- pprTrace "dsMonoBinds:PatMonoBind:" (ppr PprDebug body_expr) $ mkSelectorBinds tyvars pat [(binder, binder_subst binder) | binder <- pat_binders] diff --git a/ghc/compiler/deSugar/DsCCall.lhs b/ghc/compiler/deSugar/DsCCall.lhs index e76b251..d324b5f 100644 --- a/ghc/compiler/deSugar/DsCCall.lhs +++ b/ghc/compiler/deSugar/DsCCall.lhs @@ -26,7 +26,7 @@ import PrelInfo ( byteArrayPrimTy, getStatePairingConInfo, stringTy ) import Pretty import PrimOp ( PrimOp(..) ) -import Type ( isPrimType, maybeAppDataTyCon, eqTy ) +import Type ( isPrimType, maybeAppDataTyConExpandingDicts, eqTy ) import Util ( pprPanic, pprError, panic ) maybeBoxedPrimType = panic "DsCCall.maybeBoxedPrimType" @@ -187,7 +187,7 @@ we decide what's happening with enumerations. ADR maybe_boxed_prim_arg_ty = maybeBoxedPrimType arg_ty (Just (box_data_con, the_prim_arg_ty)) = maybe_boxed_prim_arg_ty - maybe_data_type = maybeAppDataTyCon arg_ty + maybe_data_type = maybeAppDataTyConExpandingDicts arg_ty is_data_type = maybeToBool maybe_data_type (Just (tycon, tycon_arg_tys, data_cons)) = maybe_data_type (the_data_con : other_data_cons) = data_cons @@ -288,7 +288,7 @@ boxResult result_ty = pprPanic "boxResult: " (ppr PprDebug result_ty) where - maybe_data_type = maybeAppDataTyCon result_ty + maybe_data_type = maybeAppDataTyConExpandingDicts result_ty Just (tycon, tycon_arg_tys, data_cons) = maybe_data_type (the_data_con : other_data_cons) = data_cons diff --git a/ghc/compiler/deSugar/DsExpr.lhs b/ghc/compiler/deSugar/DsExpr.lhs index 9030f94..835c9f9 100644 --- a/ghc/compiler/deSugar/DsExpr.lhs +++ b/ghc/compiler/deSugar/DsExpr.lhs @@ -49,14 +49,13 @@ import PrelInfo ( mkTupleTy, unitTy, nilDataCon, consDataCon, import Pretty ( ppShow, ppBesides, ppPStr, ppStr ) import TyCon ( isDataTyCon, isNewTyCon ) import Type ( splitSigmaTy, splitFunTy, typePrimRep, - getAppDataTyCon, getAppTyCon, applyTy + getAppDataTyConExpandingDicts, getAppTyCon, applyTy ) import TyVar ( nullTyVarEnv, addOneToTyVarEnv, GenTyVar{-instance Eq-} ) import Usage ( UVar(..) ) import Util ( zipEqual, pprError, panic, assertPanic ) maybeBoxedPrimType = panic "DsExpr.maybeBoxedPrimType" -splitTyArgs = panic "DsExpr.splitTyArgs" mk_nil_con ty = mkCon nilDataCon [] [ty] [] -- micro utility... \end{code} @@ -221,10 +220,9 @@ dsExpr (SectionL expr op) -- for the type of x, we need the type of op's 2nd argument let x_ty = case (splitSigmaTy (coreExprType core_op)) of { (_, _, tau_ty) -> - case (splitTyArgs tau_ty) of { + case (splitFunTy tau_ty) of { ((_:arg2_ty:_), _) -> arg2_ty; - _ -> panic "dsExpr:SectionL:arg 2 ty" - }} + _ -> panic "dsExpr:SectionL:arg 2 ty" }} in newSysLocalDs x_ty `thenDs` \ x_id -> returnDs (mkValLam [x_id] (core_op `App` y_atom `App` VarArg x_id)) @@ -238,10 +236,9 @@ dsExpr (SectionR op expr) -- for the type of x, we need the type of op's 1st argument let x_ty = case (splitSigmaTy (coreExprType core_op)) of { (_, _, tau_ty) -> - case (splitTyArgs tau_ty) of { + case (splitFunTy tau_ty) of { ((arg1_ty:_), _) -> arg1_ty; - _ -> panic "dsExpr:SectionR:arg 1 ty" - }} + _ -> panic "dsExpr:SectionR:arg 1 ty" }} in newSysLocalDs x_ty `thenDs` \ x_id -> returnDs (mkValLam [x_id] (core_op `App` VarArg x_id `App` y_atom)) @@ -386,7 +383,7 @@ dsExpr (RecordCon con_expr rbinds) dsExpr rhs [] -> mkErrorAppDs rEC_CON_ERROR_ID arg_ty (showForErr lbl) in - mapDs mk_arg (arg_tys `zipEqual` dataConFieldLabels con_id) `thenDs` \ con_args -> + mapDs mk_arg (zipEqual "dsExpr:RecordCon" arg_tys (dataConFieldLabels con_id)) `thenDs` \ con_args -> mkAppDs con_expr' [] con_args where -- "con_expr'" is simply an application of the constructor Id @@ -425,7 +422,8 @@ dsExpr (RecordUpdOut record_expr dicts rbinds) dsRbinds rbinds $ \ rbinds' -> let record_ty = coreExprType record_expr' - (tycon, inst_tys, cons) = _trace "getAppDataTyCon.DsExpr" $ getAppDataTyCon record_ty + (tycon, inst_tys, cons) = _trace "DsExpr.getAppDataTyConExpandingDicts" $ + getAppDataTyConExpandingDicts record_ty cons_to_upd = filter has_all_fields cons -- initial_args are passed to every constructor @@ -441,7 +439,7 @@ dsExpr (RecordUpdOut record_expr dicts rbinds) mk_alt con = newSysLocalsDs (dataConArgTys con inst_tys) `thenDs` \ arg_ids -> let - val_args = map mk_val_arg (dataConFieldLabels con `zipEqual` arg_ids) + val_args = map mk_val_arg (zipEqual "dsExpr:RecordUpd" (dataConFieldLabels con) arg_ids) in returnDs (con, arg_ids, mkGenApp (mkGenApp (Var con) initial_args) val_args) diff --git a/ghc/compiler/deSugar/DsMonad.lhs b/ghc/compiler/deSugar/DsMonad.lhs index 2900230..6236b69 100644 --- a/ghc/compiler/deSugar/DsMonad.lhs +++ b/ghc/compiler/deSugar/DsMonad.lhs @@ -154,7 +154,7 @@ duplicateLocalDs old_local us loc mod_and_grp env warns cloneTyVarsDs :: [TyVar] -> DsM [TyVar] cloneTyVarsDs tyvars us loc mod_and_grp env warns = case (getUniques (length tyvars) us) of { uniqs -> - (zipWithEqual cloneTyVar tyvars uniqs, warns) } + (zipWithEqual "cloneTyVarsDs" cloneTyVar tyvars uniqs, warns) } \end{code} \begin{code} @@ -162,7 +162,7 @@ newTyVarsDs :: [TyVar] -> DsM [TyVar] newTyVarsDs tyvar_tmpls us loc mod_and_grp env warns = case (getUniques (length tyvar_tmpls) us) of { uniqs -> - (zipWithEqual cloneTyVar tyvar_tmpls uniqs, warns) } + (zipWithEqual "newTyVarsDs" cloneTyVar tyvar_tmpls uniqs, warns) } \end{code} We can also reach out and either set/grab location information from diff --git a/ghc/compiler/deSugar/DsUtils.lhs b/ghc/compiler/deSugar/DsUtils.lhs index 411a7c1..740044b 100644 --- a/ghc/compiler/deSugar/DsUtils.lhs +++ b/ghc/compiler/deSugar/DsUtils.lhs @@ -48,8 +48,7 @@ import Id ( idType, dataConArgTys, mkTupleCon, import Literal ( Literal(..) ) import TyCon ( mkTupleTyCon, isNewTyCon, tyConDataCons ) import Type ( mkTyVarTys, mkRhoTy, mkForAllTys, mkFunTys, - isUnboxedType, applyTyCon, - getAppDataTyCon, getAppTyCon + mkTheta, isUnboxedType, applyTyCon, getAppTyCon ) import UniqSet ( mkUniqSet, minusUniqSet, uniqSetToList, UniqSet(..) ) import Util ( panic, assertPanic, pprTrace{-ToDo:rm-} ) @@ -59,8 +58,6 @@ import Pretty--ToDo:rm import TyVar--ToDo:rm import Unique--ToDo:rm import Usage--ToDo:rm - -splitDictType = panic "DsUtils.splitDictType" \end{code} %************************************************************************ @@ -449,7 +446,7 @@ mkTupleBind tyvars dicts local_global_prs tuple_expr applyTyCon (mkTupleTyCon no_of_binders) (map idType locals) where - theta = map (splitDictType . idType) dicts + theta = mkTheta (map idType dicts) mk_selector :: CoreExpr -> (Id, Id) -> Int -> DsM (Id, CoreExpr) diff --git a/ghc/compiler/deSugar/Match.lhs b/ghc/compiler/deSugar/Match.lhs index 5437929..ebddac2 100644 --- a/ghc/compiler/deSugar/Match.lhs +++ b/ghc/compiler/deSugar/Match.lhs @@ -41,7 +41,7 @@ import PrelInfo ( nilDataCon, consDataCon, mkTupleTy, mkListTy, wordTy, wordPrimTy, wordDataCon, pAT_ERROR_ID ) -import Type ( isPrimType, eqTy, getAppDataTyCon, +import Type ( isPrimType, eqTy, getAppDataTyConExpandingDicts, instantiateTauTy ) import TyVar ( GenTyVar{-instance Eq-} ) @@ -334,7 +334,7 @@ tidy1 v (RecPat con_id pat_ty rpats) match_result pats = map mk_pat tagged_arg_tys -- Boring stuff to find the arg-tys of the constructor - (_, inst_tys, _) = {-_trace "getAppDataTyCon.Match" $-} getAppDataTyCon pat_ty + (_, inst_tys, _) = {-_trace "Match.getAppDataTyConExpandingDicts" $-} getAppDataTyConExpandingDicts pat_ty con_arg_tys' = dataConArgTys con_id inst_tys tagged_arg_tys = con_arg_tys' `zip` allFieldLabelTags diff --git a/ghc/compiler/hsSyn/HsDecls.lhs b/ghc/compiler/hsSyn/HsDecls.lhs index 324b811..3bc2b5f 100644 --- a/ghc/compiler/hsSyn/HsDecls.lhs +++ b/ghc/compiler/hsSyn/HsDecls.lhs @@ -27,7 +27,7 @@ import Outputable ( interppSP, interpp'SP, ) import Pretty import SrcLoc ( SrcLoc ) -import Util ( cmpList, panic#{-ToDo:rm eventually-} ) +import Util ( panic#{-ToDo:rm eventually-} ) \end{code} %************************************************************************ diff --git a/ghc/compiler/hsSyn/HsExpr.lhs b/ghc/compiler/hsSyn/HsExpr.lhs index 5ad5ee5..65fd71e 100644 --- a/ghc/compiler/hsSyn/HsExpr.lhs +++ b/ghc/compiler/hsSyn/HsExpr.lhs @@ -207,7 +207,7 @@ pprExpr sty (HsLam match) pprExpr sty expr@(HsApp e1 e2) = let (fun, args) = collect_args expr [] in - ppHang (pprParendExpr sty fun) 4 (ppSep (map (pprParendExpr sty) args)) + ppHang (pprExpr sty fun) 4 (ppSep (map (pprExpr sty) args)) where collect_args (HsApp fun arg) args = collect_args fun (arg:args) collect_args fun args = (fun, args) @@ -217,11 +217,11 @@ pprExpr sty (OpApp e1 op e2) HsVar v -> pp_infixly v _ -> pp_prefixly where - pp_e1 = pprParendExpr sty e1 - pp_e2 = pprParendExpr sty e2 + pp_e1 = pprExpr sty e1 + pp_e2 = pprExpr sty e2 pp_prefixly - = ppHang (pprParendExpr sty op) 4 (ppSep [pp_e1, pp_e2]) + = ppHang (pprExpr sty op) 4 (ppSep [pp_e1, pp_e2]) pp_infixly v = ppSep [pp_e1, ppCat [pprSym sty v, pp_e2]] diff --git a/ghc/compiler/hsSyn/HsPat.lhs b/ghc/compiler/hsSyn/HsPat.lhs index c5d2d29..96d3082 100644 --- a/ghc/compiler/hsSyn/HsPat.lhs +++ b/ghc/compiler/hsSyn/HsPat.lhs @@ -125,11 +125,10 @@ pprInPat sty (ConPatIn c pats) = if null pats then ppr sty c else - ppBesides [ppLparen, ppr sty c, ppSP, interppSP sty pats, ppRparen] - + ppCat [ppr sty c, interppSP sty pats] -- ParPats put in the parens pprInPat sty (ConOpPatIn pat1 op pat2) - = ppBesides [ppLparen, ppr sty pat1, ppSP, ppr sty op, ppSP, ppr sty pat2, ppRparen] + = ppCat [ppr sty pat1, ppr sty op, ppr sty 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) diff --git a/ghc/compiler/hsSyn/HsTypes.lhs b/ghc/compiler/hsSyn/HsTypes.lhs index 884ee9f..945ae65 100644 --- a/ghc/compiler/hsSyn/HsTypes.lhs +++ b/ghc/compiler/hsSyn/HsTypes.lhs @@ -219,15 +219,9 @@ cmpPolyType _ _ (HsPreForAllTy _ _) = panic# "cmpPolyType:HsPreForAllTy:2nd arg" # endif cmpPolyType cmp (HsForAllTy tvs1 c1 t1) (HsForAllTy tvs2 c2 t2) - = thenCmp (cmp_tvs tvs1 tvs2) - (thenCmp (cmpContext cmp c1 c2) (cmpMonoType cmp t1 t2)) - where - cmp_tvs [] [] = EQ_ - cmp_tvs [] _ = LT_ - cmp_tvs _ [] = GT_ - cmp_tvs (a:as) (b:bs) - = thenCmp (cmp a b) (cmp_tvs as bs) - cmp_tvs _ _ = panic# "cmp_tvs" + = cmpList cmp tvs1 tvs2 `thenCmp` + cmpContext cmp c1 c2 `thenCmp` + cmpMonoType cmp t1 t2 ----------- cmpMonoType cmp (MonoTyVar n1) (MonoTyVar n2) @@ -239,13 +233,14 @@ cmpMonoType cmp (MonoListTy ty1) (MonoListTy ty2) = cmpMonoType cmp ty1 ty2 cmpMonoType cmp (MonoTyApp tc1 tys1) (MonoTyApp tc2 tys2) - = thenCmp (cmp tc1 tc2) (cmpList (cmpMonoType cmp) tys1 tys2) + = cmp tc1 tc2 `thenCmp` + cmpList (cmpMonoType cmp) tys1 tys2 cmpMonoType cmp (MonoFunTy a1 b1) (MonoFunTy a2 b2) - = thenCmp (cmpMonoType cmp a1 a2) (cmpMonoType cmp b1 b2) + = cmpMonoType cmp a1 a2 `thenCmp` cmpMonoType cmp b1 b2 cmpMonoType cmp (MonoDictTy c1 ty1) (MonoDictTy c2 ty2) - = thenCmp (cmp c1 c2) (cmpMonoType cmp ty1 ty2) + = cmp c1 c2 `thenCmp` cmpMonoType cmp ty1 ty2 cmpMonoType cmp ty1 ty2 -- tags must be different = let tag1 = tag ty1 @@ -265,7 +260,7 @@ cmpContext cmp a b = cmpList cmp_ctxt a b where cmp_ctxt (c1, tv1) (c2, tv2) - = thenCmp (cmp c1 c2) (cmp tv1 tv2) + = cmp c1 c2 `thenCmp` cmp tv1 tv2 #endif {- COMPILING_GHC -} \end{code} diff --git a/ghc/compiler/main/CmdLineOpts.lhs b/ghc/compiler/main/CmdLineOpts.lhs index 8191913..a2e7a00 100644 --- a/ghc/compiler/main/CmdLineOpts.lhs +++ b/ghc/compiler/main/CmdLineOpts.lhs @@ -217,13 +217,11 @@ opt_SpecialiseTrace = lookup SLIT("-ftrace-specialisation") opt_SpecialiseUnboxed = lookup SLIT("-fspecialise-unboxed") opt_StgDoLetNoEscapes = lookup SLIT("-flet-no-escape") opt_Verbose = lookup SLIT("-v") -opt_AsmTarget = lookup_str "-fasm=" opt_SccGroup = lookup_str "-G=" opt_ProduceC = lookup_str "-C=" opt_ProduceS = lookup_str "-S=" -opt_MustRecompile = lookup SLIT("-fmust-recompile") -opt_ProduceHi = lookup_str "-hifile=" -- the one to produce this time -opt_MyHi = lookup_str "-myhifile=" -- the one produced last time +opt_ProduceHi = lookup_str "-hifile=" -- the one to produce this time +opt_HiMap = lookup_str "-himap=" -- file saying where to look for .hi files opt_EnsureSplittableC = lookup_str "-fglobalise-toplev-names=" opt_UnfoldingUseThreshold = lookup_int "-funfolding-use-threshold" opt_UnfoldingCreationThreshold = lookup_int "-funfolding-creation-threshold" @@ -232,26 +230,6 @@ opt_ReturnInRegsThreshold = lookup_int "-freturn-in-regs-threshold" opt_NoImplicitPrelude = lookup SLIT("-fno-implicit-prelude") opt_IgnoreIfacePragmas = lookup SLIT("-fignore-interface-pragmas") - -opt_HiSuffix = case (lookup_str "-hisuffix=") of { Nothing -> ".hi" ; Just x -> x } -opt_SysHiSuffix = case (lookup_str "-syshisuffix=") of { Nothing -> ".hi" ; Just x -> x } - -opt_HiDirList = get_dir_list "-i=" -opt_SysHiDirList = get_dir_list "-j=" - -get_dir_list tag - = case (lookup_str tag) of - Nothing -> [{-no dirs to search???-}] - Just xs -> colon_split xs "" [] -- character and dir accumulators, both reversed... - where - colon_split [] cacc dacc = reverse (reverse cacc : dacc) - colon_split (':' : xs) cacc dacc = colon_split xs "" (reverse cacc : dacc) - colon_split ( x : xs) cacc dacc = colon_split xs (x : cacc) dacc - --- -hisuf, -hisuf-prelude --- -fno-implicit-prelude --- -fignore-interface-pragmas --- importdirs and sysimport dirs \end{code} \begin{code} diff --git a/ghc/compiler/main/ErrUtils.lhs b/ghc/compiler/main/ErrUtils.lhs index e50ded5..edf7a30 100644 --- a/ghc/compiler/main/ErrUtils.lhs +++ b/ghc/compiler/main/ErrUtils.lhs @@ -9,7 +9,7 @@ module ErrUtils ( Error(..), Warning(..), Message(..), addErrLoc, - addShortErrLocLine, + addShortErrLocLine, addShortWarnLocLine, dontAddErrLoc, pprBagOfErrors, ghcExit @@ -35,11 +35,16 @@ addErrLoc locn title rest_of_err_msg sty ppChar ':']) 4 (rest_of_err_msg sty) -addShortErrLocLine :: SrcLoc -> Error -> Error +addShortErrLocLine, addShortWarnLocLine :: SrcLoc -> Error -> Error + addShortErrLocLine locn rest_of_err_msg sty = ppHang (ppBeside (ppr PprForUser locn) (ppChar ':')) 4 (rest_of_err_msg sty) +addShortWarnLocLine locn rest_of_err_msg sty + = ppHang (ppBeside (ppr PprForUser locn) (ppPStr SLIT(":warning:"))) + 4 (rest_of_err_msg sty) + dontAddErrLoc :: String -> Error -> Error dontAddErrLoc title rest_of_err_msg sty = ppHang (ppBesides [ppStr title, ppChar ':']) diff --git a/ghc/compiler/main/MkIface.lhs b/ghc/compiler/main/MkIface.lhs index 796d51d..129afc1 100644 --- a/ghc/compiler/main/MkIface.lhs +++ b/ghc/compiler/main/MkIface.lhs @@ -1,5 +1,5 @@ % -% (c) The GRASP/AQUA Project, Glasgow University, 1993-1995 +% (c) The GRASP/AQUA Project, Glasgow University, 1993-1996 % \section[MkIface]{Print an interface for a module} @@ -41,7 +41,8 @@ import ParseUtils ( UsagesMap(..), VersionsMap(..) ) import PprEnv -- not sure how much... import PprStyle ( PprStyle(..) ) import PprType -- most of it (??) -import Pretty -- quite a bit +import Pretty ( prettyToUn ) +import Unpretty -- ditto import RnHsSyn ( RenamedHsModule(..), RnName{-instance NamedThing-} ) import TcModule ( TcIfaceInfo(..) ) import TcInstUtil ( InstInfo(..) ) @@ -49,27 +50,27 @@ import TyCon ( TyCon(..){-instance NamedThing-}, NewOrData(..) ) import Type ( mkSigmaTy, mkDictTy, getAppTyCon ) import Util ( sortLt, zipWithEqual, zipWith3Equal, assertPanic, panic{-ToDo:rm-}, pprTrace{-ToDo:rm-} ) -ppSemid x = ppBeside (ppr PprInterface x) ppSemi -- micro util -ppr_ty ty = pprType PprInterface ty -ppr_tyvar tv = ppr PprInterface tv +uppSemid x = uppBeside (prettyToUn (ppr PprInterface x)) uppSemi -- micro util +ppr_ty ty = prettyToUn (pprType PprInterface ty) +ppr_tyvar tv = prettyToUn (ppr PprInterface tv) ppr_name n = let on = origName n s = nameOf on - pp = ppr PprInterface on + pp = prettyToUn (ppr PprInterface on) in - (if isLexSym s then ppParens else id) pp + (if isLexSym s then uppParens else id) pp ppr_unq_name n = let on = origName n s = nameOf on - pp = ppPStr s + pp = uppPStr s in - (if isLexSym s then ppParens else id) pp + (if isLexSym s then uppParens else id) pp \end{code} We have a function @startIface@ to open the output file and put -(something like) ``interface Foo N'' in it. It gives back a handle +(something like) ``interface Foo'' in it. It gives back a handle for subsequent additions to the interface file. We then have one-function-per-block-of-interface-stuff, e.g., @@ -119,7 +120,7 @@ startIface mod Nothing -> return Nothing -- not producing any .hi file Just fn -> openFile fn WriteMode >>= \ if_hdl -> - hPutStr if_hdl ("interface "++ _UNPK_ mod ++" 1\n") >> + hPutStr if_hdl ("interface "++ _UNPK_ mod) >> return (Just if_hdl) endIface Nothing = return () @@ -133,14 +134,17 @@ ifaceUsages (Just if_hdl) usages | null usages_list = return () | otherwise - = hPutStr if_hdl "__usages__\n" >> - hPutStr if_hdl (ppShow 10000 (ppAboves (map pp_uses usages_list))) + = hPutStr if_hdl "\n__usages__\n" >> + hPutStr if_hdl (uppShow 0 (uppAboves (map upp_uses usages_list))) where usages_list = fmToList usages - pp_uses (m, (mv, versions)) - = ppBesides [ppPStr m, ppSP, ppInt mv, ppPStr SLIT(" :: "), - pp_versions (fmToList versions), ppSemi] + upp_uses (m, (mv, versions)) + = uppBesides [uppPStr m, uppSP, uppPStr SLIT(" :: "), + upp_versions (fmToList versions), uppSemi] + + upp_versions nvs + = uppIntersperse upp'SP{-'-} [ uppCat [uppPStr n, uppInt v] | (n,v) <- nvs ] \end{code} \begin{code} @@ -151,12 +155,12 @@ ifaceVersions (Just if_hdl) version_info = return () | otherwise = hPutStr if_hdl "\n__versions__\n" >> - hPutStr if_hdl (ppShow 10000 (pp_versions version_list)) + hPutStr if_hdl (uppShow 0 (upp_versions version_list)) where version_list = fmToList version_info -pp_versions nvs - = ppInterleave ppComma [ ppCat [ppPStr n, ppInt v] | (n,v) <- nvs ] + upp_versions nvs + = uppAboves [ uppPStr n | (n,v) <- nvs ] \end{code} \begin{code} @@ -165,7 +169,7 @@ ifaceInstanceModules (Just _) [] = return () ifaceInstanceModules (Just if_hdl) imods = hPutStr if_hdl "\n__instance_modules__\n" >> - hPutStr if_hdl (ppShow 100 (ppCat (map ppPStr imods))) + hPutStr if_hdl (uppShow 0 (uppCat (map uppPStr imods))) \end{code} Export list: grab the Names of things that are marked Exported, sort @@ -193,7 +197,7 @@ ifaceExportList (Just if_hdl) in hPutStr if_hdl "\n__exports__\n" >> - hPutStr if_hdl (ppShow 100 (ppAboves (map pp_pair sorted_pairs))) + hPutStr if_hdl (uppShow 0 (uppAboves (map upp_pair sorted_pairs))) where from_ty (TyData _ n _ _ _ _ _) acc = maybe_add acc n from_ty (TyNew _ n _ _ _ _ _) acc = maybe_add acc n @@ -223,11 +227,11 @@ ifaceExportList (Just if_hdl) lexical_lt (n1,_) (n2,_) = nameOrigName n1 < nameOrigName n2 -------------- - pp_pair (n, ef) - = ppBeside (ppr_name n) (pp_export ef) + upp_pair (n, ef) + = uppBeside (ppr_name n) (upp_export ef) where - pp_export ExportAll = ppPStr SLIT("(..)") - pp_export ExportAbs = ppNil + upp_export ExportAll = uppPStr SLIT("(..)") + upp_export ExportAbs = uppNil \end{code} \begin{code} @@ -241,7 +245,7 @@ ifaceFixities (Just if_hdl) (HsModule _ _ _ _ fixities _ _ _ _ _ _ _ _ _) return () else hPutStr if_hdl "\n__fixities__\n" >> - hPutStr if_hdl (ppShow 100 (ppAboves (map ppSemid local_fixities))) + hPutStr if_hdl (uppShow 0 (uppAboves (map uppSemid local_fixities))) where from_here (InfixL v _) = isLocallyDefined v from_here (InfixR v _) = isLocallyDefined v @@ -253,21 +257,23 @@ ifaceDecls Nothing{-no iface handle-} _ = return () ifaceDecls (Just if_hdl) (vals, tycons, classes, _) = let - exported_classes = filter isExported classes - exported_tycons = filter isExported tycons +-- exported_classes = filter isExported classes +-- exported_tycons = filter isExported tycons exported_vals = filter isExported vals - sorted_classes = sortLt ltLexical exported_classes - sorted_tycons = sortLt ltLexical exported_tycons + sorted_classes = sortLt ltLexical classes + sorted_tycons = sortLt ltLexical tycons sorted_vals = sortLt ltLexical exported_vals in - ASSERT(not (null exported_classes && null exported_tycons && null exported_vals)) - + if (null sorted_classes && null sorted_tycons && null sorted_vals) then + -- You could have a module with just instances in it + return () + else hPutStr if_hdl "\n__declarations__\n" >> - hPutStr if_hdl (ppShow 100 (ppAboves [ - ppAboves (map ppr_class sorted_classes), - ppAboves (map ppr_tycon sorted_tycons), - ppAboves [ppr_val v (idType v) | v <- sorted_vals]])) + hPutStr if_hdl (uppShow 0 (uppAboves [ + uppAboves (map ppr_class sorted_classes), + uppAboves (map ppr_tycon sorted_tycons), + uppAboves [ppr_val v (idType v) | v <- sorted_vals]])) \end{code} \begin{code} @@ -283,7 +289,7 @@ ifaceInstances (Just if_hdl) (_, _, _, insts) return () else hPutStr if_hdl "\n__instances__\n" >> - hPutStr if_hdl (ppShow 100 (ppAboves (map pp_inst sorted_insts))) + hPutStr if_hdl (uppShow 0 (uppAboves (map pp_inst sorted_insts))) where is_exported_inst (InstInfo clas _ ty _ _ _ _ _ from_here _ _ _) = from_here -- && ... @@ -306,7 +312,7 @@ ifaceInstances (Just if_hdl) (_, _, _, insts) forall_ty = mkSigmaTy tvs theta (mkDictTy clas ty) renumbered_ty = initNmbr (nmbrType forall_ty) in - ppBesides [ppPStr SLIT("instance "), ppr_ty renumbered_ty, ppSemi] + uppBesides [uppPStr SLIT("instance "), ppr_ty renumbered_ty, uppSemi] \end{code} %************************************************************************ @@ -316,33 +322,30 @@ ifaceInstances (Just if_hdl) (_, _, _, insts) %************************************************************************ \begin{code} -ppr_class :: Class -> Pretty +ppr_class :: Class -> Unpretty ppr_class c = --pprTrace "ppr_class:" (ppr PprDebug c) $ case (initNmbr (nmbrClass c)) of { -- renumber it! Class _ n tyvar super_classes sdsels ops sels defms insts links -> - ppAbove (ppCat [ppPStr SLIT("class"), ppr_theta tyvar super_classes, - ppr_name n, ppr_tyvar tyvar, - if null ops then ppSemi else ppStr "where {"]) - (if (null ops) - then ppNil - else ppAbove (ppNest 2 (ppAboves (map ppr_op ops))) - (ppStr "};") - ) + uppCat [uppPStr SLIT("class"), ppr_theta tyvar super_classes, + ppr_name n, ppr_tyvar tyvar, + if null ops + then uppSemi + else uppCat [uppStr "where {", uppCat (map ppr_op ops), uppStr "};"]] } where - ppr_theta :: TyVar -> [Class] -> Pretty + ppr_theta :: TyVar -> [Class] -> Unpretty - ppr_theta tv [] = ppNil - ppr_theta tv [sc] = ppBeside (ppr_assert tv sc) (ppStr " =>") + ppr_theta tv [] = uppNil + ppr_theta tv [sc] = uppBeside (ppr_assert tv sc) (uppPStr SLIT(" =>")) ppr_theta tv super_classes - = ppBesides [ppLparen, - ppIntersperse pp'SP{-'-} (map (ppr_assert tv) super_classes), - ppStr ") =>"] + = uppBesides [uppLparen, + uppIntersperse upp'SP{-'-} (map (ppr_assert tv) super_classes), + uppStr ") =>"] - ppr_assert tv (Class _ n _ _ _ _ _ _ _ _) = ppCat [ppr_name n, ppr_tyvar tv] + ppr_assert tv (Class _ n _ _ _ _ _ _ _ _) = uppCat [ppr_name n, ppr_tyvar tv] ppr_op (ClassOp o _ ty) = pp_sig (Unqual o) ty \end{code} @@ -353,7 +356,7 @@ ppr_val v ty -- renumber the type first! pp_sig v (initNmbr (nmbrType ty)) pp_sig op ty - = ppBesides [ppr_name op, ppPStr SLIT(" :: "), ppr_ty ty, ppSemi] + = uppBesides [ppr_name op, uppPStr SLIT(" :: "), ppr_ty ty, uppSemi] \end{code} \begin{code} @@ -363,40 +366,40 @@ ppr_tycon tycon ------------------------ ppr_tc (PrimTyCon _ n _) - = ppCat [ ppStr "{- data", ppr_name n, ppStr " *built-in* -}" ] + = uppCat [ uppStr "{- data", ppr_name n, uppStr " *built-in* -}" ] ppr_tc FunTyCon - = ppCat [ ppStr "{- data", ppr_name FunTyCon, ppStr " *built-in* -}" ] + = uppCat [ uppStr "{- data", ppr_name FunTyCon, uppStr " *built-in* -}" ] ppr_tc (TupleTyCon _ n _) - = ppCat [ ppStr "{- ", ppr_name n, ppStr "-}" ] + = uppCat [ uppStr "{- ", ppr_name n, uppStr "-}" ] ppr_tc (SynTyCon _ n _ _ tvs expand) = let pp_tyvars = map ppr_tyvar tvs in - ppBesides [ppPStr SLIT("type "), ppr_name n, ppSP, ppIntersperse ppSP pp_tyvars, - ppPStr SLIT(" = "), ppr_ty expand, ppSemi] + uppBesides [uppPStr SLIT("type "), ppr_name n, uppSP, uppIntersperse uppSP pp_tyvars, + uppPStr SLIT(" = "), ppr_ty expand, uppSemi] ppr_tc this_tycon@(DataTyCon u n k tvs ctxt cons derivings data_or_new) - = ppHang (ppCat [pp_data_or_new, - ppr_context ctxt, - ppr_name n, - ppIntersperse ppSP (map ppr_tyvar tvs)]) - 2 - (ppBeside pp_unabstract_condecls ppSemi) + = uppCat [pp_data_or_new, + ppr_context ctxt, + ppr_name n, + uppIntersperse uppSP (map ppr_tyvar tvs), + pp_unabstract_condecls, + uppSemi] -- NB: we do not print deriving info in interfaces where pp_data_or_new = case data_or_new of - DataType -> ppPStr SLIT("data") - NewType -> ppPStr SLIT("newtype") + DataType -> uppPStr SLIT("data") + NewType -> uppPStr SLIT("newtype") - ppr_context [] = ppNil - ppr_context [(c,t)] = ppCat [ppr_name c, ppr_ty t, ppStr "=>"] + ppr_context [] = uppNil + ppr_context [(c,t)] = uppCat [ppr_name c, ppr_ty t, uppPStr SLIT("=>")] ppr_context cs - = ppBesides[ppLparen, - ppInterleave ppComma [ppCat [ppr_name c, ppr_ty t] | (c,t) <- cs], - ppRparen, ppStr " =>"] + = uppBesides[uppLparen, + uppInterleave uppComma [uppCat [ppr_name c, ppr_ty t] | (c,t) <- cs], + uppRparen, uppPStr SLIT(" =>")] yes_we_print_condecls = case (getExportFlag n) of @@ -405,16 +408,16 @@ ppr_tc this_tycon@(DataTyCon u n k tvs ctxt cons derivings data_or_new) pp_unabstract_condecls = if yes_we_print_condecls - then ppCat [ppEquals, pp_condecls] - else ppNil + then uppCat [uppEquals, pp_condecls] + else uppNil pp_condecls = let (c:cs) = cons in - ppSep ((ppr_con c) : (map ppr_next_con cs)) + uppCat ((ppr_con c) : (map ppr_next_con cs)) - ppr_next_con con = ppCat [ppChar '|', ppr_con con] + ppr_next_con con = uppCat [uppChar '|', ppr_con con] ppr_con con = let @@ -422,22 +425,22 @@ ppr_tc this_tycon@(DataTyCon u n k tvs ctxt cons derivings data_or_new) labels = dataConFieldLabels con -- none if not a record strict_marks = dataConStrictMarks con in - ppCat [ppr_unq_name con, ppr_fields labels strict_marks con_arg_tys] + uppCat [ppr_unq_name con, ppr_fields labels strict_marks con_arg_tys] ppr_fields labels strict_marks con_arg_tys = if null labels then -- not a record thingy - ppIntersperse ppSP (zipWithEqual ppr_bang_ty strict_marks con_arg_tys) + uppIntersperse uppSP (zipWithEqual "ppr_fields" ppr_bang_ty strict_marks con_arg_tys) else - ppCat [ ppChar '{', - ppInterleave ppComma (zipWith3Equal ppr_field labels strict_marks con_arg_tys), - ppChar '}' ] + uppCat [ uppChar '{', + uppInterleave uppComma (zipWith3Equal "ppr_field" ppr_field labels strict_marks con_arg_tys), + uppChar '}' ] ppr_bang_ty b t - = ppBeside (case b of { MarkedStrict -> ppChar '!'; _ -> ppNil }) - (pprParendType PprInterface t) + = uppBeside (case b of { MarkedStrict -> uppChar '!'; _ -> uppNil }) + (prettyToUn (pprParendType PprInterface t)) ppr_field l b t - = ppBesides [ppr_unq_name l, ppPStr SLIT(" :: "), - case b of { MarkedStrict -> ppChar '!'; _ -> ppNil }, + = uppBesides [ppr_unq_name l, uppPStr SLIT(" :: "), + case b of { MarkedStrict -> uppChar '!'; _ -> uppNil }, ppr_ty t] \end{code} diff --git a/ghc/compiler/nativeGen/MachRegs.lhs b/ghc/compiler/nativeGen/MachRegs.lhs index 156dab3..32159f1 100644 --- a/ghc/compiler/nativeGen/MachRegs.lhs +++ b/ghc/compiler/nativeGen/MachRegs.lhs @@ -310,9 +310,9 @@ instance Outputable Reg where ppr sty r = ppStr (show r) #endif -cmpReg (FixedReg i) (FixedReg i') = cmp_ihash i i' -cmpReg (MappedReg i) (MappedReg i') = cmp_ihash i i' -cmpReg (MemoryReg i _) (MemoryReg i' _) = cmp_i i i' +cmpReg (FixedReg i) (FixedReg i') = cmp_ihash i i' +cmpReg (MappedReg i) (MappedReg i') = cmp_ihash i i' +cmpReg (MemoryReg i _) (MemoryReg i' _) = cmp_i i i' cmpReg (UnmappedReg u _) (UnmappedReg u' _) = cmp u u' cmpReg r1 r2 = let tag1 = tagReg r1 diff --git a/ghc/compiler/nativeGen/PprMach.lhs b/ghc/compiler/nativeGen/PprMach.lhs index f1835a3..65a5edc 100644 --- a/ghc/compiler/nativeGen/PprMach.lhs +++ b/ghc/compiler/nativeGen/PprMach.lhs @@ -379,7 +379,10 @@ pprAddr (AddrRegImm r1 imm) \begin{code} pprInstr :: Instr -> Unpretty -pprInstr (COMMENT s) = uppBeside (uppPStr SLIT("\t# ")) (uppPStr s) +pprInstr (COMMENT s) = uppNil -- nuke 'em +--alpha: = uppBeside (uppPStr SLIT("\t# ")) (uppPStr s) +--i386 : = uppBeside (uppPStr SLIT("# ")) (uppPStr s) +--sparc: = uppBeside (uppPStr SLIT("! ")) (uppPStr s) pprInstr (SEGMENT TextSegment) = uppPStr diff --git a/ghc/compiler/prelude/PrelInfo.lhs b/ghc/compiler/prelude/PrelInfo.lhs index 460893a..c6b04a2 100644 --- a/ghc/compiler/prelude/PrelInfo.lhs +++ b/ghc/compiler/prelude/PrelInfo.lhs @@ -68,6 +68,7 @@ module PrelInfo ( intPrimTy, intTy, intPrimTyCon, intTyCon, intDataCon, wordPrimTyCon, wordPrimTy, wordTy, wordTyCon, wordDataCon, addrPrimTyCon, addrPrimTy, addrTy, addrTyCon, addrDataCon, + maybeIntLikeTyCon, maybeCharLikeTyCon, -- types: Integer, Rational (= Ratio Integer) integerTy, rationalTy, @@ -412,13 +413,15 @@ class_keys , (SLIT("Floating"), floatingClassKey) -- numeric , (SLIT("RealFrac"), realFracClassKey) -- numeric , (SLIT("RealFloat"), realFloatClassKey) -- numeric --- , (SLIT("Ix"), ixClassKey) +-- , (SLIT("Ix"), ixClassKey) -- derivable (but it isn't Prelude.Ix; hmmm) , (SLIT("Bounded"), boundedClassKey) -- derivable , (SLIT("Enum"), enumClassKey) -- derivable , (SLIT("Show"), showClassKey) -- derivable , (SLIT("Read"), readClassKey) -- derivable , (SLIT("Monad"), monadClassKey) , (SLIT("MonadZero"), monadZeroClassKey) + , (SLIT("MonadPlus"), monadPlusClassKey) + , (SLIT("Functor"), functorClassKey) , (SLIT("CCallable"), cCallableClassKey) -- mentioned, ccallish , (SLIT("CReturnable"), cReturnableClassKey) -- mentioned, ccallish ]] @@ -435,3 +438,9 @@ class_op_keys , (SLIT("=="), eqClassOpKey) ]] \end{code} + +ToDo: make it do the ``like'' part properly (as in 0.26 and before). +\begin{code} +maybeCharLikeTyCon tc = if (uniqueOf tc == charDataConKey) then Just charDataCon else Nothing +maybeIntLikeTyCon tc = if (uniqueOf tc == intDataConKey) then Just intDataCon else Nothing +\end{code} diff --git a/ghc/compiler/prelude/PrelVals.lhs b/ghc/compiler/prelude/PrelVals.lhs index 8aac8e6..506b50e 100644 --- a/ghc/compiler/prelude/PrelVals.lhs +++ b/ghc/compiler/prelude/PrelVals.lhs @@ -145,7 +145,7 @@ unpackCStringAppendId = pcMiscPrelId unpackCStringAppendIdKey pRELUDE_BUILTIN SLIT("unpackAppendPS#") (mkFunTys [addrPrimTy{-a "char *" pointer-},stringTy] stringTy) ((noIdInfo - `addInfo_UF` mkMagicUnfolding unpackCStringAppendIdKey) + {-LATER:`addInfo_UF` mkMagicUnfolding unpackCStringAppendIdKey-}) `addInfo` mkArityInfo 2) unpackCStringFoldrId @@ -156,7 +156,7 @@ unpackCStringFoldrId alphaTy] alphaTy)) ((noIdInfo - `addInfo_UF` mkMagicUnfolding unpackCStringFoldrIdKey) + {-LATER:`addInfo_UF` mkMagicUnfolding unpackCStringFoldrIdKey-}) `addInfo` mkArityInfo 3) \end{code} @@ -455,7 +455,7 @@ realWorldPrimId buildId = pcMiscPrelId buildIdKey pRELUDE_CORE SLIT("_build") buildTy ((((noIdInfo - `addInfo_UF` mkMagicUnfolding buildIdKey) + {-LATER:`addInfo_UF` mkMagicUnfolding buildIdKey-}) `addInfo` mkStrictnessInfo [WwStrict] Nothing) `addInfo` mkArgUsageInfo [ArgUsage 2]) `addInfo` pcGenerateSpecs buildIdKey buildId noIdInfo{-ToDo-} buildTy) @@ -500,7 +500,7 @@ mkBuild ty tv c n g expr augmentId = pcMiscPrelId augmentIdKey pRELUDE_CORE SLIT("_augment") augmentTy (((noIdInfo - `addInfo_UF` mkMagicUnfolding augmentIdKey) + {-LATER:`addInfo_UF` mkMagicUnfolding augmentIdKey-}) `addInfo` mkStrictnessInfo [WwStrict,WwLazy False] Nothing) `addInfo` mkArgUsageInfo [ArgUsage 2,UnknownArgUsage]) -- cheating, but since _augment never actually exists ... @@ -523,7 +523,7 @@ foldrId = pcMiscPrelId foldrIdKey pRELUDE_FB{-not "List"-} SLIT("foldr") (mkFunTys [mkFunTys [alphaTy, betaTy] betaTy, betaTy, mkListTy alphaTy] betaTy) idInfo = (((((noIdInfo - `addInfo_UF` mkMagicUnfolding foldrIdKey) + {-LATER:`addInfo_UF` mkMagicUnfolding foldrIdKey-}) `addInfo` mkStrictnessInfo [WwLazy False,WwLazy False,WwStrict] Nothing) `addInfo` mkArityInfo 3) `addInfo` mkUpdateInfo [2,2,1]) @@ -537,7 +537,7 @@ foldlId = pcMiscPrelId foldlIdKey pRELUDE_FB{-not "List"-} SLIT("foldl") (mkFunTys [mkFunTys [alphaTy, betaTy] alphaTy, alphaTy, mkListTy betaTy] alphaTy) idInfo = (((((noIdInfo - `addInfo_UF` mkMagicUnfolding foldlIdKey) + {-LATER:`addInfo_UF` mkMagicUnfolding foldlIdKey-}) `addInfo` mkStrictnessInfo [WwLazy False,WwLazy False,WwStrict] Nothing) `addInfo` mkArityInfo 3) `addInfo` mkUpdateInfo [2,2,1]) diff --git a/ghc/compiler/prelude/PrimOp.lhs b/ghc/compiler/prelude/PrimOp.lhs index 11d5e28..1874d83 100644 --- a/ghc/compiler/prelude/PrimOp.lhs +++ b/ghc/compiler/prelude/PrimOp.lhs @@ -42,7 +42,7 @@ import PprType ( pprParendGenType, GenTyVar{-instance Outputable-} ) import Pretty import SMRep ( SMRep(..), SMSpecRepKind(..), SMUpdateKind(..) ) import TyCon ( TyCon{-instances-} ) -import Type ( getAppDataTyCon, maybeAppDataTyCon, +import Type ( getAppDataTyConExpandingDicts, maybeAppDataTyConExpandingDicts, mkForAllTys, mkFunTys, applyTyCon, typePrimRep ) import TyVar ( alphaTyVar, betaTyVar, GenTyVar{-instance Eq-} ) @@ -1285,7 +1285,8 @@ primOpInfo ErrorIOPrimOp -- errorIO# :: PrimIO () -> State# RealWorld# primOpInfo (CCallOp _ _ _ arg_tys result_ty) = AlgResult SLIT("ccall#") [] arg_tys result_tycon tys_applied where - (result_tycon, tys_applied, _) = _trace "getAppDataTyCon.PrimOp" $ getAppDataTyCon result_ty + (result_tycon, tys_applied, _) = _trace "PrimOp.getAppDataTyConExpandingDicts" $ + getAppDataTyConExpandingDicts result_ty \end{code} %************************************************************************ @@ -1345,7 +1346,7 @@ primOpHeapReq (CCallOp _ _ mayGC@False _ return_ty) else NoHeapRequired where returnsMallocPtr - = case (maybeAppDataTyCon return_ty) of + = case (maybeAppDataTyConExpandingDicts return_ty) of Nothing -> False Just (tycon, _, _) -> tycon == stateAndMallocPtrPrimTyCon diff --git a/ghc/compiler/prelude/TysWiredIn.lhs b/ghc/compiler/prelude/TysWiredIn.lhs index 8d89294..2efbb84 100644 --- a/ghc/compiler/prelude/TysWiredIn.lhs +++ b/ghc/compiler/prelude/TysWiredIn.lhs @@ -81,6 +81,7 @@ module TysWiredIn ( stringTyCon, trueDataCon, unitTy, + voidTy, voidTyCon, wordDataCon, wordTy, wordTyCon @@ -110,7 +111,7 @@ import TyCon ( mkDataTyCon, mkTupleTyCon, mkSynTyCon, NewOrData(..), TyCon ) import Type ( mkTyConTy, applyTyCon, mkSynTy, mkSigmaTy, - mkFunTys, maybeAppDataTyCon, + mkFunTys, maybeAppDataTyConExpandingDicts, GenType(..), ThetaType(..), TauType(..) ) import TyVar ( tyVarKind, alphaTyVar, betaTyVar ) import Unique @@ -153,6 +154,13 @@ pcGenerateDataSpecs ty %************************************************************************ \begin{code} +-- The Void type is represented as a data type with no constructors +voidTy = mkTyConTy voidTyCon + +voidTyCon = pcDataTyCon voidTyConKey pRELUDE_BUILTIN SLIT("Void") [] [] +\end{code} + +\begin{code} charTy = mkTyConTy charTyCon charTyCon = pcDataTyCon charTyConKey pRELUDE_BUILTIN SLIT("Char") [] [charDataCon] @@ -401,7 +409,7 @@ getStatePairingConInfo Type) -- type of state pair getStatePairingConInfo prim_ty - = case (maybeAppDataTyCon prim_ty) of + = case (maybeAppDataTyConExpandingDicts prim_ty) of Nothing -> panic "getStatePairingConInfo:1" Just (prim_tycon, tys_applied, _) -> let @@ -683,7 +691,7 @@ mkLiftTy ty (tvs, theta, tau) = splitSigmaTy ty isLiftTy ty - = case maybeAppDataTyCon tau of + = case (maybeAppDataTyConExpandingDicts tau) of Just (tycon, tys, _) -> tycon == liftTyCon Nothing -> False where diff --git a/ghc/compiler/profiling/CostCentre.lhs b/ghc/compiler/profiling/CostCentre.lhs index 4253749..b5beb1f 100644 --- a/ghc/compiler/profiling/CostCentre.lhs +++ b/ghc/compiler/profiling/CostCentre.lhs @@ -271,10 +271,7 @@ cmpCostCentre DontCareCC DontCareCC = EQ_ cmpCostCentre (NormalCC k1 m1 _ _ c1) (NormalCC k2 m2 _ _ c2) -- first key is module name, then we use "kinds" (which include -- names) - = case (_CMP_STRING_ m1 m2) of - LT_ -> LT_ - EQ_ -> cmp_kind k1 k2 - GT__ -> GT_ + = _CMP_STRING_ m1 m2 `thenCmp` cmp_kind k1 k2 cmpCostCentre other_1 other_2 = let diff --git a/ghc/compiler/reader/ReadPrefix.lhs b/ghc/compiler/reader/ReadPrefix.lhs index cb8be08..0aa0e50 100644 --- a/ghc/compiler/reader/ReadPrefix.lhs +++ b/ghc/compiler/reader/ReadPrefix.lhs @@ -22,7 +22,7 @@ import PrefixToHs import CmdLineOpts ( opt_CompilingPrelude ) import ErrUtils ( addErrLoc, ghcExit ) import FiniteMap ( elemFM, FiniteMap ) -import Name ( RdrName(..), isRdrLexCon ) +import Name ( RdrName(..), isRdrLexConOrSpecial ) import PprStyle ( PprStyle(..) ) import PrelMods ( fromPrelude ) import Pretty @@ -379,7 +379,7 @@ wlkPat pat U_ident nn -> -- simple identifier wlkQid nn `thenUgn` \ n -> returnUgn ( - if isRdrLexCon n + if isRdrLexConOrSpecial n then ConPatIn n [] else VarPatIn n ) diff --git a/ghc/compiler/rename/ParseIface.y b/ghc/compiler/rename/ParseIface.y index bae7fda..d87feb2 100644 --- a/ghc/compiler/rename/ParseIface.y +++ b/ghc/compiler/rename/ParseIface.y @@ -130,6 +130,7 @@ name_version_pair : iname INTEGER exports_part :: { ExportsMap } exports_part : EXPORTS_PART export_items { bagToFM $2 } + | { emptyFM } export_items :: { Bag (FAST_STRING, (RdrName, ExportFlag)) } export_items : export_item { unitBag $1 } @@ -171,6 +172,7 @@ fix : INFIXL INTEGER qop SEMI { (de_qual $3, InfixL $3 (fromInteger $2)) } decls_part :: { (LocalTyDefsMap, LocalValDefsMap) } decls_part : DECLARATIONS_PART topdecls { $2 } + | { (emptyFM, emptyFM) } topdecls :: { (LocalTyDefsMap, LocalValDefsMap) } topdecls : topdecl { $1 } diff --git a/ghc/compiler/rename/Rename.lhs b/ghc/compiler/rename/Rename.lhs index 780017a..1a96999 100644 --- a/ghc/compiler/rename/Rename.lhs +++ b/ghc/compiler/rename/Rename.lhs @@ -32,11 +32,11 @@ import ParseUtils ( ParsedIface(..), RdrIfaceDecl(..), RdrIfaceInst(..), import RnMonad import RnNames ( getGlobalNames, GlobalNameInfo(..) ) import RnSource ( rnSource ) -import RnIfaces ( findHiFiles, rnIfaces ) +import RnIfaces ( rnIfaces ) import RnUtils ( RnEnv(..), extendGlobalRnEnv, emptyRnEnv, multipleOccWarn ) import Bag ( isEmptyBag, unionBags, unionManyBags, bagToList, listToBag ) -import CmdLineOpts ( opt_HiDirList, opt_SysHiDirList ) +import CmdLineOpts ( opt_HiMap ) import ErrUtils ( Error(..), Warning(..) ) import FiniteMap ( emptyFM, eltsFM, fmToList, lookupFM{-ToDo:rm-} ) import Maybes ( catMaybes ) @@ -80,7 +80,8 @@ renameModule us input@(HsModule mod _ _ imports _ _ _ _ _ _ _ _ _ _) -- , ppCat (map ppPStr (keysFM b_keys)) -- ]}) $ - findHiFiles opt_HiDirList opt_SysHiDirList >>= \ hi_files -> + makeHiMap opt_HiMap >>= \ hi_files -> +-- pprTrace "HiMap:\n" (ppAboves [ ppCat [ppPStr m, ppStr p] | (m,p) <- fmToList hi_files]) newVar (emptyFM,emptyFM,hi_files){-init iface cache-} `thenPrimIO` \ iface_cache -> fixIO ( \ ~(_, _, _, _, rec_occ_fm, rec_export_fn) -> @@ -195,6 +196,27 @@ renameModule us input@(HsModule mod _ _ imports _ _ _ _ _ _ _ _ _ _) \end{code} \begin{code} +makeHiMap :: Maybe String -> IO (FiniteMap Module FilePath) + +makeHiMap Nothing = error "Rename.makeHiMap:no .hi map given by the GHC driver (?)" +makeHiMap (Just f) + = readFile f >>= \ cts -> + return (snag_mod emptyFM cts []) + where + -- we alternate between "snag"ging mod(ule names) and path(names), + -- accumulating names (reversed) and the final resulting map + -- as we move along. + + snag_mod map [] [] = map + snag_mod map (' ':cs) rmod = snag_path map (_PK_ (reverse rmod)) cs [] + snag_mod map (c:cs) rmod = snag_mod map cs (c:rmod) + + snag_path map mod [] rpath = addToFM map mod (reverse rpath) + snag_path map mod ('\n':cs) rpath = snag_mod (addToFM map mod (reverse rpath)) cs [] + snag_path map mod (c:cs) rpath = snag_path map mod cs (c:rpath) +\end{code} + +\begin{code} {- TESTING: pprPIface (ParsedIface m ?? v mv usgs lcm exm ims lfx ltdm lvdm lids ldp) = ppAboves [ diff --git a/ghc/compiler/rename/RnExpr.lhs b/ghc/compiler/rename/RnExpr.lhs index 5f6790e..d00312c 100644 --- a/ghc/compiler/rename/RnExpr.lhs +++ b/ghc/compiler/rename/RnExpr.lhs @@ -487,7 +487,7 @@ precParseExpr exp@(OpApp (OpApp e11 (HsVar op1) e12) (HsVar op) e2) = lookupFixity op `thenRn` \ (op_fix, op_prec) -> lookupFixity op1 `thenRn` \ (op1_fix, op1_prec) -> -- pprTrace "precParse:" (ppCat [ppr PprDebug op, ppInt op_prec, ppr PprDebug op1, ppInt op1_prec]) $ - case cmp op1_prec op_prec of + case (op1_prec `cmp` op_prec) of LT_ -> rearrange EQ_ -> case (op1_fix, op_fix) of (INFIXR, INFIXR) -> rearrange @@ -515,7 +515,7 @@ precParsePat pat@(ConOpPatIn (NegPatIn e1) op e2) precParsePat pat@(ConOpPatIn (ConOpPatIn p11 op1 p12) op p2) = lookupFixity op `thenRn` \ (op_fix, op_prec) -> lookupFixity op1 `thenRn` \ (op1_fix, op1_prec) -> - case cmp op1_prec op_prec of + case (op1_prec `cmp` op_prec) of LT_ -> rearrange EQ_ -> case (op1_fix, op_fix) of (INFIXR, INFIXR) -> rearrange diff --git a/ghc/compiler/rename/RnIfaces.lhs b/ghc/compiler/rename/RnIfaces.lhs index 97445c9..299a1f3 100644 --- a/ghc/compiler/rename/RnIfaces.lhs +++ b/ghc/compiler/rename/RnIfaces.lhs @@ -7,7 +7,7 @@ #include "HsVersions.h" module RnIfaces ( - findHiFiles, +-- findHiFiles, cachedIface, cachedDecl, readIface, @@ -35,14 +35,13 @@ import ParseUtils ( ParsedIface(..), RdrIfaceDecl(..), RdrIfaceInst(..), import Bag ( emptyBag, unitBag, consBag, snocBag, unionBags, unionManyBags, isEmptyBag, bagToList ) -import CmdLineOpts ( opt_HiSuffix, opt_SysHiSuffix ) import ErrUtils ( Error(..), Warning(..) ) import FiniteMap ( emptyFM, lookupFM, addToFM, addToFM_C, plusFM, eltsFM, fmToList, delListFromFM, sizeFM, foldFM, unitFM, plusFM_C, keysFM{-ToDo:rm-} ) import Maybes ( maybeToBool ) -import Name ( moduleNamePair, origName, isRdrLexCon, RdrName(..) ) +import Name ( moduleNamePair, origName, RdrName(..) ) import PprStyle -- ToDo:rm import Outputable -- ToDo:rm import PrelInfo ( builtinNameInfo ) @@ -75,6 +74,7 @@ type IfaceCache Return a mapping from module-name to absolute-filename-for-that-interface. \begin{code} +{- OLD: findHiFiles :: [FilePath] -> [FilePath] -> IO (FiniteMap Module FilePath) findHiFiles dirs sysdirs @@ -136,6 +136,7 @@ findHiFiles dirs sysdirs else Just cand where is_modname_char c = isAlphanum c || c == '_' +-} \end{code} ********************************************************* @@ -795,9 +796,9 @@ finalIfaceInfo :: finalIfaceInfo iface_cache modname if_final_env@((qual, unqual, tc_qual, tc_unqual), stack) if_instdecls = - pprTrace "usageIf:qual:" (ppCat [ppBesides[ppPStr m,ppChar '.',ppPStr n] | (n,m) <- keysFM qual]) $ +-- pprTrace "usageIf:qual:" (ppCat [ppBesides[ppPStr m,ppChar '.',ppPStr n] | (n,m) <- keysFM qual]) $ -- pprTrace "usageIf:unqual:" (ppCat (map ppPStr (keysFM unqual))) $ - pprTrace "usageIf:tc_qual:" (ppCat [ppBesides[ppPStr m,ppChar '.',ppPStr n] | (n,m) <- keysFM tc_qual]) $ +-- pprTrace "usageIf:tc_qual:" (ppCat [ppBesides[ppPStr m,ppChar '.',ppPStr n] | (n,m) <- keysFM tc_qual]) $ -- pprTrace "usageIf:tc_unqual:" (ppCat (map ppPStr (keysFM tc_unqual))) $ let val_stuff@(val_usages, val_versions) diff --git a/ghc/compiler/rename/RnMonad.lhs b/ghc/compiler/rename/RnMonad.lhs index dd1ec55..cde9eef 100644 --- a/ghc/compiler/rename/RnMonad.lhs +++ b/ghc/compiler/rename/RnMonad.lhs @@ -43,7 +43,8 @@ import RnHsSyn ( RnName, mkRnName, mkRnUnbound, mkRnImplicit, import RnUtils ( RnEnv(..), extendLocalRnEnv, lookupRnEnv, lookupGlobalRnEnv, lookupTcRnEnv, unknownNameErr, badClassOpErr, qualNameErr, - dupNamesErr, shadowedNameWarn, negateNameWarn ) + dupNamesErr, shadowedNameWarn, negateNameWarn + ) import Bag ( Bag, emptyBag, isEmptyBag, snocBag ) import CmdLineOpts ( opt_WarnNameShadowing ) @@ -306,7 +307,7 @@ newLocalNames str names_w_loc mkLocalNames :: [(RdrName, SrcLoc)] -> RnMonad x s [RnName] mkLocalNames names_w_locs = rnGetUniques (length names_w_locs) `thenRn` \ uniqs -> - returnRn (zipWithEqual new_local uniqs names_w_locs) + returnRn (zipWithEqual "mkLocalNames" new_local uniqs names_w_locs) where new_local uniq (Unqual str, srcloc) = mkRnName (mkLocalName uniq str srcloc) diff --git a/ghc/compiler/rename/RnNames.lhs b/ghc/compiler/rename/RnNames.lhs index 53d04e1..0f70372 100644 --- a/ghc/compiler/rename/RnNames.lhs +++ b/ghc/compiler/rename/RnNames.lhs @@ -22,14 +22,15 @@ import RnHsSyn import RnMonad import RnIfaces ( IfaceCache(..), cachedIface, cachedDecl ) import RnUtils ( RnEnv(..), emptyRnEnv, extendGlobalRnEnv, - lubExportFlag, qualNameErr, dupNamesErr, negateNameWarn ) + lubExportFlag, qualNameErr, dupNamesErr, negateNameWarn + ) import ParseUtils ( ParsedIface(..), RdrIfaceDecl(..), RdrIfaceInst ) import Bag ( emptyBag, unitBag, consBag, snocBag, unionBags, unionManyBags, mapBag, filterBag, listToBag, bagToList ) import CmdLineOpts ( opt_NoImplicitPrelude ) -import ErrUtils ( Error(..), Warning(..), addErrLoc, addShortErrLocLine ) +import ErrUtils ( Error(..), Warning(..), addErrLoc, addShortErrLocLine, addShortWarnLocLine ) import FiniteMap ( emptyFM, addListToFM, lookupFM, fmToList, eltsFM, delListFromFM ) import Id ( GenId ) import Maybes ( maybeToBool, catMaybes, MaybeErr(..) ) @@ -777,33 +778,33 @@ globalDupNamesErr rdr rns sty message = ppBesides [ppStr "multiple declarations of `", pprNonSym sty rdr, ppStr "'"] pp_dup rn = addShortErrLocLine (get_loc rn) (\ sty -> - ppBesides [pp_descrip rn, pprNonSym sty rn]) sty + ppCat [pp_descrip rn, pprNonSym sty rn]) sty get_loc rn = case getImpLocs rn of [] -> getSrcLoc rn locs -> head locs - pp_descrip (RnName _) = ppStr "a value" - pp_descrip (RnSyn _) = ppStr "a type synonym" - pp_descrip (RnData _ _ _) = ppStr "a data type" - pp_descrip (RnConstr _ _) = ppStr "a data constructor" - pp_descrip (RnField _ _) = ppStr "a record field" - pp_descrip (RnClass _ _) = ppStr "a class" - pp_descrip (RnClassOp _ _) = ppStr "a class method" + pp_descrip (RnName _) = ppStr "as a value:" + pp_descrip (RnSyn _) = ppStr "as a type synonym:" + pp_descrip (RnData _ _ _) = ppStr "as a data type:" + pp_descrip (RnConstr _ _) = ppStr "as a data constructor:" + pp_descrip (RnField _ _) = ppStr "as a record field:" + pp_descrip (RnClass _ _) = ppStr "as a class:" + pp_descrip (RnClassOp _ _) = ppStr "as a class method:" pp_descrip _ = ppNil dupImportWarn (ImportDecl m1 _ _ _ locn1 : dup_imps) sty = ppAboves (item1 : map dup_item dup_imps) where - item1 = addShortErrLocLine locn1 (\ sty -> + item1 = addShortWarnLocLine locn1 (\ sty -> ppCat [ppStr "multiple imports from module", ppPStr m1]) sty dup_item (ImportDecl m _ _ _ locn) - = addShortErrLocLine locn (\ sty -> + = addShortWarnLocLine locn (\ sty -> ppCat [ppStr "here was another import from module", ppPStr m]) sty qualPreludeImportWarn (ImportDecl m _ _ _ locn) - = addShortErrLocLine locn (\ sty -> + = addShortWarnLocLine locn (\ sty -> ppCat [ppStr "qualified import of prelude module", ppPStr m]) unknownImpSpecErr ie imp_mod locn @@ -815,7 +816,7 @@ duplicateImpSpecErr ie imp_mod locn ppBesides [ppStr "`", ppr sty (ie_name ie), ppStr "' already seen in import list"]) allWhenSynImpSpecWarn n imp_mod locn - = addShortErrLocLine locn (\ sty -> + = addShortWarnLocLine locn (\ sty -> ppBesides [ppStr "type synonym `", ppr sty n, ppStr "' should not be imported with (..)"]) allWhenAbsImpSpecErr n imp_mod locn diff --git a/ghc/compiler/rename/RnSource.lhs b/ghc/compiler/rename/RnSource.lhs index 0291b37..6050153 100644 --- a/ghc/compiler/rename/RnSource.lhs +++ b/ghc/compiler/rename/RnSource.lhs @@ -21,7 +21,7 @@ import RnUtils ( lookupGlobalRnEnv, lubExportFlag ) import Bag ( emptyBag, unitBag, consBag, unionManyBags, unionBags, listToBag, bagToList ) import Class ( derivableClassKeys ) -import ErrUtils ( addErrLoc, addShortErrLocLine ) +import ErrUtils ( addErrLoc, addShortErrLocLine, addShortWarnLocLine ) import FiniteMap ( emptyFM, lookupFM, addListToFM_C ) import ListSetOps ( unionLists, minusList ) import Maybes ( maybeToBool, catMaybes ) @@ -193,8 +193,9 @@ rnIE mods (IEThingAll name) checkIEAll (RnData n cons fields) = returnRn (exp_all n `consBag` listToBag (map exp_all cons) `unionBags` listToBag (map exp_all fields)) checkIEAll (RnClass n ops) = returnRn (exp_all n `consBag` listToBag (map exp_all ops)) - checkIEAll rn@(RnSyn _) = getSrcLocRn `thenRn` \ src_loc -> - warnAndContinueRn emptyBag (synAllExportErr rn src_loc) + checkIEAll rn@(RnSyn n) = getSrcLocRn `thenRn` \ src_loc -> + warnAndContinueRn (unitBag (n, ExportAbs)) + (synAllExportErr False{-warning-} rn src_loc) checkIEAll rn = returnRn emptyBag exp_all n = (n, ExportAll) @@ -218,7 +219,7 @@ rnIE mods (IEThingWith name names) = rnWithErr "class ops" rn ops rns checkIEWith rn@(RnSyn _) rns = getSrcLocRn `thenRn` \ src_loc -> - failButContinueRn emptyBag (synAllExportErr rn src_loc) + failButContinueRn emptyBag (synAllExportErr True{-error-} rn src_loc) checkIEWith rn rns = returnRn emptyBag @@ -661,7 +662,7 @@ rnContext tv_env ctxt \begin{code} dupNameExportWarn locn names@((n,_):_) - = addShortErrLocLine locn (\ sty -> + = addShortWarnLocLine locn (\ sty -> ppCat [pprNonSym sty n, ppStr "exported", ppInt (length names), ppStr "times"]) dupLocalsExportErr locn locals@((str,_):_) @@ -672,13 +673,13 @@ classOpExportErr op locn = addShortErrLocLine locn (\ sty -> ppBesides [ppStr "class operation `", ppr sty op, ppStr "' can only be exported with class"]) -synAllExportErr syn locn - = addShortErrLocLine locn (\ sty -> +synAllExportErr is_error syn locn + = (if is_error then addShortErrLocLine else addShortWarnLocLine) locn (\ sty -> ppBesides [ppStr "type synonym `", ppr sty syn, ppStr "' should be exported abstractly"]) withExportErr str rn has rns locn = addErrLoc locn "" (\ sty -> - ppAboves [ ppBesides [ppStr "inconsistent list of", ppStr str, ppStr "in export list for `", ppr sty rn, ppStr "'"], + ppAboves [ ppBesides [ppStr "inconsistent list of ", ppStr str, ppStr " in export list for `", ppr sty rn, ppStr "'"], ppCat [ppStr " expected:", ppInterleave ppComma (map (ppr sty) has)], ppCat [ppStr " found: ", ppInterleave ppComma (map (ppr sty) rns)] ]) @@ -691,11 +692,11 @@ badModExportErr mod locn ppCat [ ppStr "unknown module in export list: module", ppPStr mod]) emptyModExportWarn locn mod - = addShortErrLocLine locn (\ sty -> + = addShortWarnLocLine locn (\ sty -> ppCat [ppStr "module", ppPStr mod, ppStr "has no unqualified imports to export"]) dupModExportWarn locn mods@(mod:_) - = addShortErrLocLine locn (\ sty -> + = addShortWarnLocLine locn (\ sty -> ppCat [ppStr "module", ppPStr mod, ppStr "appears", ppInt (length mods), ppStr "times in export list"]) derivingNonStdClassErr clas locn diff --git a/ghc/compiler/rename/RnUtils.lhs b/ghc/compiler/rename/RnUtils.lhs index f27614c..ba38151 100644 --- a/ghc/compiler/rename/RnUtils.lhs +++ b/ghc/compiler/rename/RnUtils.lhs @@ -26,7 +26,7 @@ module RnUtils ( import Ubiq import Bag ( Bag, emptyBag, snocBag, unionBags ) -import ErrUtils ( addShortErrLocLine, addErrLoc ) +import ErrUtils ( addShortErrLocLine, addShortWarnLocLine, addErrLoc ) import FiniteMap ( FiniteMap, emptyFM, isEmptyFM, lookupFM, addListToFM, addToFM ) import Maybes ( maybeToBool ) @@ -197,15 +197,15 @@ dupNamesErr descriptor ((name1,locn1) : dup_things) sty pprNonSym sty name, ppStr "'" ]) sty shadowedNameWarn locn shadow - = addShortErrLocLine locn ( \ sty -> + = addShortWarnLocLine locn ( \ sty -> ppBesides [ppStr "more than one value with the same name (shadowing): ", ppr sty shadow] ) multipleOccWarn (name, occs) sty - = ppBesides [ppStr "multiple names used to refer to `", ppr sty name, ppStr "': ", + = ppBesides [ppStr "warning:multiple names used to refer to `", ppr sty name, ppStr "': ", ppInterleave ppComma (map (ppr sty) occs)] negateNameWarn (name,locn) - = addShortErrLocLine locn ( \ sty -> + = addShortWarnLocLine locn ( \ sty -> ppBesides [ppStr "local binding of `negate' will be used for prefix `-'"]) \end{code} diff --git a/ghc/compiler/simplCore/AnalFBWW.lhs b/ghc/compiler/simplCore/AnalFBWW.lhs index 43a5646..136c4bf 100644 --- a/ghc/compiler/simplCore/AnalFBWW.lhs +++ b/ghc/compiler/simplCore/AnalFBWW.lhs @@ -59,7 +59,7 @@ maybeFBtoFB (Nothing) = IsNotFB addArgs :: Int -> OurFBType -> OurFBType addArgs n (IsFB (FBType args prod)) - = IsFB (FBType (take n (repeat FBBadConsum) ++ args) prod) + = IsFB (FBType (nOfThem n FBBadConsum ++ args) prod) addArgs n IsNotFB = IsNotFB addArgs n IsCons = panic "adding argument to a cons" addArgs n IsBottom = IsNotFB @@ -74,7 +74,7 @@ joinFBType :: OurFBType -> OurFBType -> OurFBType joinFBType (IsBottom) a = a joinFBType a (IsBottom) = a joinFBType (IsFB (FBType args prod)) (IsFB (FBType args' prod')) - | length args == length args' = (IsFB (FBType (zipWith argJ args args') + | length args == length args' = (IsFB (FBType (zipWith{-Equal-} argJ args args') (prodJ prod prod'))) where argJ FBGoodConsum FBGoodConsum = FBGoodConsum diff --git a/ghc/compiler/simplCore/FloatIn.lhs b/ghc/compiler/simplCore/FloatIn.lhs index a49aadb..b09986e 100644 --- a/ghc/compiler/simplCore/FloatIn.lhs +++ b/ghc/compiler/simplCore/FloatIn.lhs @@ -25,7 +25,7 @@ import FreeVars import Id ( emptyIdSet, unionIdSets, unionManyIdSets, elementOfIdSet, IdSet(..) ) -import Util ( panic ) +import Util ( nOfThem, panic, zipEqual ) \end{code} Top-level interface function, @floatInwards@. Note that we do not @@ -268,7 +268,7 @@ fiExpr to_drop (_,AnnLet (AnnRec bindings) body) -> [(Id, CoreExpr)] fi_bind to_drops pairs - = [ (binder, fiExpr to_drop rhs) | ((binder, rhs), to_drop) <- zip pairs to_drops ] + = [ (binder, fiExpr to_drop rhs) | ((binder, rhs), to_drop) <- zipEqual "fi_bind" pairs to_drops ] \end{code} For @Case@, the possible ``drop points'' for the \tr{to_drop} @@ -303,13 +303,13 @@ fiExpr to_drop (_, AnnCase scrut alts) fi_alts to_drop_deflt to_drop_alts (AnnAlgAlts alts deflt) = AlgAlts [ (con, params, fiExpr to_drop rhs) - | ((con, params, rhs), to_drop) <- alts `zip` to_drop_alts ] + | ((con, params, rhs), to_drop) <- zipEqual "fi_alts" alts to_drop_alts ] (fi_default to_drop_deflt deflt) fi_alts to_drop_deflt to_drop_alts (AnnPrimAlts alts deflt) = PrimAlts [ (lit, fiExpr to_drop rhs) - | ((lit, rhs), to_drop) <- alts `zip` to_drop_alts ] + | ((lit, rhs), to_drop) <- zipEqual "fi_alts2" alts to_drop_alts ] (fi_default to_drop_deflt deflt) fi_default to_drop AnnNoDefault = NoDefault @@ -354,8 +354,7 @@ sepBindsByDropPoint drop_pts floaters (per_drop_pt, must_stay_here, _) --= sep drop_pts emptyIdSet{-fvs of prev drop_pts-} floaters = split' drop_pts floaters [] empty_boxes - empty_boxes = take (length drop_pts) (repeat []) - + empty_boxes = nOfThem (length drop_pts) [] in (map reverse per_drop_pt, reverse must_stay_here) where diff --git a/ghc/compiler/simplCore/FoldrBuildWW.lhs b/ghc/compiler/simplCore/FoldrBuildWW.lhs index a456fde..55a0e31 100644 --- a/ghc/compiler/simplCore/FoldrBuildWW.lhs +++ b/ghc/compiler/simplCore/FoldrBuildWW.lhs @@ -14,7 +14,7 @@ import CoreSyn ( CoreBinding(..) ) import Util ( panic{-ToDo:rm?-} ) --import Type ( cloneTyVarFromTemplate, mkTyVarTy, --- splitTypeWithDictsAsArgs, eqTyCon, mkForallTy ) +-- splitFunTyExpandingDicts, eqTyCon, mkForallTy ) --import TysPrim ( alphaTy ) --import TyVar ( alphaTyVar ) -- @@ -137,7 +137,7 @@ try_split_bind id expr = n_ty = alphaTy n_ty_templ = alphaTy - (templ,arg_tys,res) = splitTypeWithDictsAsArgs (idType id) + (templ,arg_tys,res) = splitFunTyExpandingDicts (idType id) expr_ty = getListTy res getListTy res = panic "FoldrBuildWW:getListTy:ToDo" {-LATER:case res of UniData lty [ty] | lty `eqTyCon` listTyCon -> ty diff --git a/ghc/compiler/simplCore/MagicUFs.lhs b/ghc/compiler/simplCore/MagicUFs.lhs index 47d0a27..ad986d7 100644 --- a/ghc/compiler/simplCore/MagicUFs.lhs +++ b/ghc/compiler/simplCore/MagicUFs.lhs @@ -22,7 +22,7 @@ import SimplEnv ( SimplEnv ) import SimplMonad ( SmplM(..), SimplCount ) import Type ( mkFunTys ) import Unique ( Unique{-instances-} ) -import Util ( assoc, zipWith3Equal, panic ) +import Util ( assoc, zipWith3Equal, nOfThem, panic ) \end{code} %************************************************************************ @@ -199,7 +199,7 @@ foldr_fun env (TypeArg ty1:TypeArg ty2:ValArg arg_k:ValArg arg_z:ValArg arg_list tick Foldr_List `thenSmpl_` newIds ( mkFunTys [ty1, ty2] ty2 : - take (length the_list) (repeat ty2) + nOfThem (length the_list) ty2 ) `thenSmpl` \ (f_id:ele_id1:ele_ids) -> let fst_bind = NonRec @@ -209,7 +209,7 @@ foldr_fun env (TypeArg ty1:TypeArg ty2:ValArg arg_k:ValArg arg_z:ValArg arg_list ValArg (VarArg f_id), ValArg arg_z, ValArg the_tl]) - rest_binds = zipWith3Equal + rest_binds = zipWith3Equal "Foldr:rest_binds" (\ e v e' -> NonRec e (mkRhs v e')) ele_ids (reverse (tail the_list)) @@ -520,10 +520,10 @@ foldl_fun env (TypeArg ty1:TypeArg ty2:ValArg arg_k:ValArg arg_z:ValArg arg_list tick Foldl_List `thenSmpl_` newIds ( mkFunTys [ty1, ty2] ty1 : - take (length the_list) (repeat ty1) + nOfThem (length the_list) ty1 ) `thenSmpl` \ (f_id:ele_ids) -> let - rest_binds = zipWith3Equal + rest_binds = zipWith3Equal "foldl:rest_binds" (\ e v e' -> NonRec e (mkRhs v e')) ele_ids -- :: [Id] the_list -- :: [CoreArg] diff --git a/ghc/compiler/simplCore/OccurAnal.lhs b/ghc/compiler/simplCore/OccurAnal.lhs index c6567da..cc7d4fb 100644 --- a/ghc/compiler/simplCore/OccurAnal.lhs +++ b/ghc/compiler/simplCore/OccurAnal.lhs @@ -41,7 +41,7 @@ import PprType ( GenType{-instance Outputable-}, GenTyVar{-ditto-} ) import Pretty ( ppAboves ) import TyVar ( GenTyVar{-instance Eq-} ) import Unique ( Unique{-instance Eq-} ) -import Util ( assoc, pprTrace, panic ) +import Util ( assoc, zipEqual, pprTrace, panic ) isSpecPragmaId_maybe = panic "OccurAnal.isSpecPragmaId_maybe (ToDo)" \end{code} @@ -336,7 +336,7 @@ occAnalBind env (Rec pairs) body_usage total_usage = foldr combineUsageDetails body_usage rhs_usages (combined_usage, tagged_binders) = tagBinders total_usage sCC - new_bind = Rec (tagged_binders `zip` rhss') + new_bind = Rec (zipEqual "occAnalBind" tagged_binders rhss') \end{code} @occAnalRhs@ deals with the question of bindings where the Id is marked diff --git a/ghc/compiler/simplCore/SAT.lhs b/ghc/compiler/simplCore/SAT.lhs index 062dada..72c6709 100644 --- a/ghc/compiler/simplCore/SAT.lhs +++ b/ghc/compiler/simplCore/SAT.lhs @@ -72,7 +72,7 @@ doStaticArgs binds sat_bind (Rec pairs) = emptyEnvSAT `thenSAT_` mapSAT satExpr rhss `thenSAT` \ rhss' -> - returnSAT (Rec (binders `zip` rhss')) + returnSAT (Rec (zipEqual "doStaticArgs" binders rhss')) where (binders, rhss) = unzip pairs \end{code} @@ -163,7 +163,7 @@ satExpr (Let (Rec binds) body) in satExpr body `thenSAT` \ body' -> mapSAT satExpr rhss `thenSAT` \ rhss' -> - returnSAT (Let (Rec (binders `zip` rhss')) body') + returnSAT (Let (Rec (zipEqual "satExpr:Rec" binders rhss')) body') satExpr (SCC cc expr) = satExpr expr `thenSAT` \ expr2 -> diff --git a/ghc/compiler/simplCore/SATMonad.lhs b/ghc/compiler/simplCore/SATMonad.lhs index eb0b36d..627ade9 100644 --- a/ghc/compiler/simplCore/SATMonad.lhs +++ b/ghc/compiler/simplCore/SATMonad.lhs @@ -31,7 +31,7 @@ module SATMonad ( ) where import Type ( mkTyVarTy, mkSigmaTy, TyVarTemplate, - splitSigmaTy, splitTyArgs, + splitSigmaTy, splitFunTy, glueTyArgs, instantiateTy, TauType(..), Class, ThetaType(..), SigmaType(..), InstTyEnv(..) @@ -240,7 +240,7 @@ saTransform binder rhs where -- get type info for the local function: (tv_tmpl, dict_tys, tau_ty) = (splitSigmaTy . idType) binder - (reg_arg_tys, res_type) = splitTyArgs tau_ty + (reg_arg_tys, res_type) = splitFunTy tau_ty -- now, we drop the ones that are -- static, that is, the ones we will not pass to the local function diff --git a/ghc/compiler/simplCore/SetLevels.lhs b/ghc/compiler/simplCore/SetLevels.lhs index 7427ad4..d1b50a5 100644 --- a/ghc/compiler/simplCore/SetLevels.lhs +++ b/ghc/compiler/simplCore/SetLevels.lhs @@ -47,7 +47,7 @@ import UniqSupply ( thenUs, returnUs, mapUs, mapAndUnzipUs, mapAndUnzip3Us, getUnique, UniqSM(..) ) import Usage ( UVar(..) ) -import Util ( mapAccumL, zipWithEqual, panic, assertPanic ) +import Util ( mapAccumL, zipWithEqual, zipEqual, panic, assertPanic ) isLeakFreeType x y = False -- safe option; ToDo \end{code} @@ -214,7 +214,7 @@ lvlBind ctxt_lvl envs@(venv, tenv) (AnnRec pairs) binders_w_lvls = binders `zip` repeat final_lvl new_envs = (growIdEnvList venv binders_w_lvls, tenv) in - returnLvl (extra_binds ++ [Rec (binders_w_lvls `zip` rhss')], new_envs) + returnLvl (extra_binds ++ [Rec (zipEqual "lvlBind" binders_w_lvls rhss')], new_envs) where (binders,rhss) = unzip pairs \end{code} @@ -568,11 +568,11 @@ type lambdas. \begin{code} decideRecFloatLevel ctxt_lvl envs@(venv, tenv) ids rhss | isTopMajLvl ids_only_lvl && -- Destination = top - not (all canFloatToTop (tys `zip` rhss)) -- Some can't float to top + not (all canFloatToTop (zipEqual "decideRec" tys rhss)) -- Some can't float to top = -- Pin it here let ids_w_lvls = ids `zip` repeat ctxt_lvl - new_envs = (growIdEnvList venv ids_w_lvls, tenv) + new_envs = (growIdEnvList venv ids_w_lvls, tenv) in mapLvl (lvlExpr ctxt_lvl new_envs) rhss `thenLvl` \ rhss' -> returnLvl (ctxt_lvl, [], rhss') @@ -605,20 +605,20 @@ decideRecFloatLevel ctxt_lvl envs@(venv, tenv) ids rhss mapLvl (lvlExpr incd_lvl new_envs) rhss `thenLvl` \ rhss' -> mapLvl newLvlVar poly_tys `thenLvl` \ poly_vars -> let - ids_w_poly_vars = ids `zip` poly_vars + ids_w_poly_vars = zipEqual "decideRec2" ids poly_vars -- The "d_rhss" are the right-hand sides of "D" and "D'" -- in the documentation above d_rhss = [ mkTyApp (Var poly_var) offending_tyvar_tys | poly_var <- poly_vars] -- "local_binds" are "D'" in the documentation above - local_binds = zipWithEqual NonRec ids_w_incd_lvl d_rhss + local_binds = zipWithEqual "SetLevels" NonRec ids_w_incd_lvl d_rhss poly_var_rhss = [ mkTyLam offending_tyvars (foldr Let rhs' local_binds) | rhs' <- rhss' -- mkCoLet* requires Core... ] - poly_binds = [(poly_var, ids_only_lvl) | poly_var <- poly_vars] `zip` poly_var_rhss + poly_binds = zipEqual "poly_binds" [(poly_var, ids_only_lvl) | poly_var <- poly_vars] poly_var_rhss in returnLvl (ctxt_lvl, [Rec poly_binds], d_rhss) diff --git a/ghc/compiler/simplCore/SimplCase.lhs b/ghc/compiler/simplCore/SimplCase.lhs index a539af9..3ec493a 100644 --- a/ghc/compiler/simplCore/SimplCase.lhs +++ b/ghc/compiler/simplCore/SimplCase.lhs @@ -33,7 +33,7 @@ import PrimOp ( primOpOkForSpeculation, PrimOp{-instance Eq-} ) import SimplEnv import SimplMonad import SimplUtils ( mkValLamTryingEta ) -import Type ( isPrimType, maybeAppDataTyCon, mkFunTys, eqTy ) +import Type ( isPrimType, maybeAppDataTyConExpandingDicts, mkFunTys, eqTy ) import Unique ( Unique{-instance Eq-} ) import Usage ( GenUsage{-instance Eq-} ) import Util ( isIn, isSingleton, zipEqual, panic, assertPanic ) @@ -681,7 +681,7 @@ completeAlgCaseWithKnownCon env con con_args (AlgAlts alts deflt) rhs_c | alt_con == con = -- Matching alternative! let - new_env = extendIdEnvWithAtomList env (zipEqual alt_args (filter isValArg con_args)) + new_env = extendIdEnvWithAtomList env (zipEqual "SimplCase" alt_args (filter isValArg con_args)) in rhs_c new_env rhs @@ -791,7 +791,7 @@ mkCoCase scrut (AlgAlts outer_alts v | scrut_is_var = Var scrut_var | otherwise = Con con (map TyArg arg_tys ++ map VarArg args) - arg_tys = case maybeAppDataTyCon (idType deflt_var) of + arg_tys = case (maybeAppDataTyConExpandingDicts (idType deflt_var)) of Just (_, arg_tys, _) -> arg_tys mkCoCase scrut (PrimAlts diff --git a/ghc/compiler/simplCore/SimplEnv.lhs b/ghc/compiler/simplCore/SimplEnv.lhs index ba098ea..ade1cfa 100644 --- a/ghc/compiler/simplCore/SimplEnv.lhs +++ b/ghc/compiler/simplCore/SimplEnv.lhs @@ -71,7 +71,7 @@ import PprCore -- various instances import PprStyle ( PprStyle(..) ) import PprType ( GenType, GenTyVar ) import Pretty -import Type ( eqTy, getAppDataTyCon, applyTypeEnvToTy ) +import Type ( eqTy, getAppDataTyConExpandingDicts, applyTypeEnvToTy ) import TyVar ( nullTyVarEnv, addOneToIdEnv, addOneToTyVarEnv, growTyVarEnvList, TyVarEnv(..), GenTyVar{-instance Eq-} @@ -80,7 +80,7 @@ import Unique ( Unique{-instance Outputable-} ) import UniqFM ( addToUFM_Directly, lookupUFM_Directly, ufmToList ) import UniqSet -- lots of things import Usage ( UVar(..), GenUsage{-instances-} ) -import Util ( zipEqual, panic, panic#, assertPanic ) +import Util ( zipEqual, thenCmp, cmpList, panic, panic#, assertPanic ) type TypeEnv = TyVarEnv Type cmpType = panic "cmpType (SimplEnv)" @@ -253,8 +253,8 @@ data UnfoldItem -- a glorified triple... -- that was in force. data UnfoldConApp -- yet another glorified pair - = UCA OutId -- same fields as ConForm - [OutArg] + = UCA OutId -- data constructor + [OutArg] -- *value* arguments; see use below data UnfoldEnv -- yup, a glorified triple... = UFE (IdEnv UnfoldItem) -- Maps an OutId => its UnfoldItem @@ -264,10 +264,13 @@ data UnfoldEnv -- yup, a glorified triple... -- These are the ones we have to worry -- about when adding new items to the -- unfold env. - (FiniteMap UnfoldConApp OutId) + (FiniteMap UnfoldConApp [([Type], OutId)]) -- Maps applications of constructors (to - -- types & atoms) back to OutIds that are - -- bound to them; i.e., this is a reversed + -- value atoms) back to an association list + -- that says "if the constructor was applied + -- to one of these lists-of-Types, then + -- this OutId is your man (in a non-gender-specific + -- sense)". I.e., this is a reversed -- mapping for (part of) the main IdEnv -- (1st part of UFE) @@ -308,13 +311,7 @@ grow_unfold_env (UFE u_env interesting_ids con_apps) id uf_details encl_cc where new_con_apps = case uf_details of - ConForm con args - -> case (lookupFM con_apps entry) of - Just _ -> con_apps -- unchanged; we hang onto what we have - Nothing -> addToFM con_apps entry id - where - entry = UCA con args - + ConForm con args -> snd (lookup_conapp_help con_apps con args id) not_a_constructor -> con_apps -- unchanged addto_unfold_env (UFE u_env interesting_ids con_apps) extra_items @@ -343,7 +340,33 @@ lookup_unfold_env_encl_cc (UFE u_env _ _) id Just (UnfoldItem _ _ encl_cc) -> encl_cc lookup_conapp (UFE _ _ con_apps) con args - = lookupFM con_apps (UCA con args) + = fst (lookup_conapp_help con_apps con args (panic "lookup_conapp")) + +-- Returns two things; we just fst or snd the one we want: +lookup_conapp_help con_apps con args outid + = case (span notValArg args) of { (ty_args, val_args) -> + let + entry = UCA con val_args + arg_tys = [ t | TyArg t <- ty_args ] + in + case (lookupFM con_apps entry) of + Nothing -> (Nothing, + addToFM con_apps entry [(arg_tys, outid)]) + Just assocs + -> ASSERT(not (null assocs)) + case [ oid | (ts,oid) <- assocs, ts `eq_tys` arg_tys ] of + [o] -> (Just o, + con_apps) -- unchanged; we hang onto what we have + [] -> (Nothing, + addToFM con_apps entry ((arg_tys, outid) : assocs)) + _ -> panic "grow_unfold_env:dup in assoc list" + } + where + eq_tys ts1 ts2 + = case (cmpList cmp_ty ts1 ts2) of { EQ_ -> True; _ -> False } + + cmp_ty ty1 ty2 -- NB: we really only know how to do *equality* on types + = if (ty1 `eqTy` ty2) then EQ_ else LT_{-random choice-} modify_unfold_env (UFE u_env interesting_ids con_apps) zapper id = UFE (modifyIdEnv u_env zapper id) interesting_ids con_apps @@ -374,22 +397,13 @@ instance Ord3 UnfoldConApp where cmp = cmp_app cmp_app (UCA c1 as1) (UCA c2 as2) - = case (c1 `cmp` c2) of - LT_ -> LT_ - GT_ -> GT_ - _ -> cmp_lists cmp_arg as1 as2 + = cmp c1 c2 `thenCmp` cmpList cmp_arg as1 as2 where - cmp_lists cmp_item [] [] = EQ_ - cmp_lists cmp_item (x:xs) [] = GT_ - cmp_lists cmp_item [] (y:ys) = LT_ - cmp_lists cmp_item (x:xs) (y:ys) - = case cmp_item x y of { EQ_ -> cmp_lists cmp_item xs ys; other -> other } - -- ToDo: make an "instance Ord3 CoreArg"??? cmp_arg (VarArg x) (VarArg y) = x `cmp` y cmp_arg (LitArg x) (LitArg y) = case _tagCmp x y of { _LT -> LT_; _EQ -> EQ_; GT__ -> GT_ } - cmp_arg (TyArg x) (TyArg y) = if x `eqTy` y then EQ_ else panic# "SimplEnv.cmp_app:TyArgs" + cmp_arg (TyArg x) (TyArg y) = panic# "SimplEnv.cmp_app:TyArgs" cmp_arg (UsageArg x) (UsageArg y) = panic# "SimplEnv.cmp_app:UsageArgs" cmp_arg x y | tag x _LT_ tag y = LT_ @@ -397,8 +411,8 @@ cmp_app (UCA c1 as1) (UCA c2 as2) where tag (VarArg _) = ILIT(1) tag (LitArg _) = ILIT(2) - tag (TyArg _) = ILIT(3) - tag (UsageArg _) = ILIT(4) + tag (TyArg _) = panic# "SimplEnv.cmp_app:TyArg" + tag (UsageArg _) = panic# "SimplEnv.cmp_app:UsageArg" \end{code} %************************************************************************ @@ -597,7 +611,7 @@ extendIdEnvWithClones (SimplEnv chkr encl_cc ty_env id_env unfold_env) in_binders out_ids = SimplEnv chkr encl_cc ty_env new_id_env unfold_env where - new_id_env = growIdEnvList id_env (in_ids `zipEqual` out_vals) + new_id_env = growIdEnvList id_env (zipEqual "extendIdEnvWithClones" in_ids out_vals) in_ids = [id | (id,_) <- in_binders] out_vals = [ItsAnAtom (VarArg out_id) | out_id <- out_ids] @@ -646,7 +660,7 @@ extendUnfoldEnvGivenConstructor env var con args = let -- conjure up the types to which the con should be applied scrut_ty = idType var - (_, ty_args, _) = getAppDataTyCon scrut_ty + (_, ty_args, _) = getAppDataTyConExpandingDicts scrut_ty in extendUnfoldEnvGivenFormDetails env var (ConForm con (map VarArg args)) diff --git a/ghc/compiler/simplCore/SimplMonad.lhs b/ghc/compiler/simplCore/SimplMonad.lhs index 1569843..4855ede 100644 --- a/ghc/compiler/simplCore/SimplMonad.lhs +++ b/ghc/compiler/simplCore/SimplMonad.lhs @@ -292,7 +292,7 @@ combineSimplCounts (SimplCount n1 stuff1) (SimplCount n2 stuff2) #else combineSimplCounts (SimplCount n1 stuff1) (SimplCount n2 stuff2) = SimplCount (n1 _ADD_ n2) - (zipWithEqual (\ (t1,c1) (t2,c2) -> (t1,c1+c2)) stuff1 stuff2) + (zipWithEqual "combineSimplCounts" (\ (t1,c1) (t2,c2) -> (t1,c1+c2)) stuff1 stuff2) #endif \end{code} @@ -311,7 +311,7 @@ newId ty us sc newIds :: [Type] -> SmplM [Id] newIds tys us sc - = (zipWithEqual mk_id tys uniqs, sc) + = (zipWithEqual "newIds" mk_id tys uniqs, sc) where uniqs = getUniques (length tys) us mk_id ty uniq = mkSysLocal SLIT("s") uniq ty mkUnknownSrcLoc diff --git a/ghc/compiler/simplCore/SimplUtils.lhs b/ghc/compiler/simplCore/SimplUtils.lhs index f046fa8..ba1cc4e 100644 --- a/ghc/compiler/simplCore/SimplUtils.lhs +++ b/ghc/compiler/simplCore/SimplUtils.lhs @@ -36,7 +36,7 @@ import PrelInfo ( augmentId, buildId, realWorldStateTy ) import PrimOp ( primOpIsCheap ) import SimplEnv import SimplMonad -import Type ( eqTy, isPrimType, maybeAppDataTyCon, getTyVar_maybe ) +import Type ( eqTy, isPrimType, maybeAppDataTyConExpandingDicts, getTyVar_maybe ) import TyVar ( GenTyVar{-instance Eq-} ) import Util ( isIn, panic ) @@ -372,7 +372,7 @@ mkIdentityAlts rhs_ty returnSmpl (PrimAlts [] (BindDefault (binder, bad_occ_info) (Var binder))) | otherwise - = case (maybeAppDataTyCon rhs_ty) of + = case (maybeAppDataTyConExpandingDicts rhs_ty) of Just (tycon, ty_args, [data_con]) -> -- algebraic type suitable for unpacking let inst_con_arg_tys = dataConArgTys data_con ty_args @@ -405,7 +405,7 @@ simplIdWantsToBeINLINEd id env type_ok_for_let_to_case :: Type -> Bool type_ok_for_let_to_case ty - = case (maybeAppDataTyCon ty) of + = case (maybeAppDataTyConExpandingDicts ty) of Nothing -> False Just (tycon, ty_args, []) -> False Just (tycon, ty_args, non_null_data_cons) -> True diff --git a/ghc/compiler/simplCore/SimplVar.lhs b/ghc/compiler/simplCore/SimplVar.lhs index 44319c7..f6eecf2 100644 --- a/ghc/compiler/simplCore/SimplVar.lhs +++ b/ghc/compiler/simplCore/SimplVar.lhs @@ -34,7 +34,7 @@ import Pretty ( ppBesides, ppStr ) import SimplEnv import SimplMonad import TyCon ( tyConFamilySize ) -import Type ( isPrimType, getAppDataTyCon, maybeAppDataTyCon ) +import Type ( isPrimType, getAppDataTyConExpandingDicts, maybeAppDataTyConExpandingDicts ) import Util ( pprTrace, assertPanic, panic ) \end{code} @@ -257,7 +257,7 @@ discountedCost env con_discount_weight size no_args is_con_vec args = let full_price = disc size take_something_off v = let - (tycon, _, _) = getAppDataTyCon (idType v) + (tycon, _, _) = getAppDataTyConExpandingDicts (idType v) no_cons = tyConFamilySize tycon reduced_size = size - (no_cons * con_discount_weight) @@ -312,7 +312,7 @@ leastItCouldCost con_discount_weight size no_val_args is_con_vec arg_tys if not want_con_here then disc size want_cons rest_arg_tys else - case (maybeAppDataTyCon arg_ty, isPrimType arg_ty) of + case (maybeAppDataTyConExpandingDicts arg_ty, isPrimType arg_ty) of (Just (tycon, _, _), False) -> disc (take_something_off tycon) want_cons rest_arg_tys diff --git a/ghc/compiler/simplCore/Simplify.lhs b/ghc/compiler/simplCore/Simplify.lhs index b9aa029..9ef9b2a 100644 --- a/ghc/compiler/simplCore/Simplify.lhs +++ b/ghc/compiler/simplCore/Simplify.lhs @@ -40,7 +40,7 @@ import SimplUtils import Type ( mkTyVarTy, mkTyVarTys, mkAppTy, splitFunTy, getFunTy_maybe, eqTy ) -import Util ( isSingleton, panic, pprPanic, assertPanic ) +import Util ( isSingleton, zipEqual, panic, pprPanic, assertPanic ) \end{code} The controlling flags, and what they do @@ -551,7 +551,7 @@ simplRhsExpr env binder@(id,occ_info) rhs = -- Deal with the big lambda part mapSmpl cloneTyVarSmpl tyvars `thenSmpl` \ tyvars' -> let - lam_env = extendTyEnvList rhs_env (tyvars `zip` (mkTyVarTys tyvars')) + lam_env = extendTyEnvList rhs_env (zipEqual "simplRhsExpr" tyvars (mkTyVarTys tyvars')) in -- Deal with the little lambda part -- Note that we call simplLam even if there are no binders, in case @@ -690,18 +690,17 @@ simplCoerce env coercion ty (Let bind body) args = simplBind env bind (\env -> simplCoerce env coercion ty body args) (computeResultType env body args) --- Cancellation -simplCoerce env (CoerceIn con1) ty (Coerce (CoerceOut con2) ty2 expr) args - | con1 == con2 - = simplExpr env expr args -simplCoerce env (CoerceOut con1) ty (Coerce (CoerceIn con2) ty2 expr) args - | con1 == con2 - = simplExpr env expr args - -- Default case simplCoerce env coercion ty expr args = simplExpr env expr [] `thenSmpl` \ expr' -> - returnSmpl (mkGenApp (Coerce coercion (simplTy env ty) expr') args) + returnSmpl (mkGenApp (mkCoerce coercion (simplTy env ty) expr') args) + where + + -- Try cancellation; we do this "on the way up" because + -- I think that's where it'll bite best + mkCoerce (CoerceIn con1) ty1 (Coerce (CoerceOut con2) ty2 body) | con1 == con2 = body + mkCoerce (CoerceOut con1) ty1 (Coerce (CoerceIn con2) ty2 body) | con1 == con2 = body + mkCoerce coercion ty body = Coerce coercion ty body \end{code} @@ -844,7 +843,7 @@ simplBind env (NonRec binder@(id,occ_info) rhs) body_c body_ty ------------------------------------------- done_float env rhs body_c = simplRhsExpr env binder rhs `thenSmpl` \ rhs' -> - completeLet env binder rhs rhs' body_c body_ty + completeLet env binder rhs' body_c body_ty --------------------------------------- try_float env (Let bind rhs) body_c @@ -973,7 +972,7 @@ simplBind env (Rec pairs) body_c body_ty cloneIds env binders `thenSmpl` \ ids' -> let env_w_clones = extendIdEnvWithClones env binders ids' - triples = ids' `zip` floated_pairs + triples = zipEqual "simplBind" ids' floated_pairs in simplRecursiveGroup env_w_clones triples `thenSmpl` \ (binding, new_env) -> @@ -1137,13 +1136,12 @@ x. That's just what completeLetBinding does. completeLet :: SimplEnv -> InBinder - -> InExpr -- Original RHS -> OutExpr -- The simplified RHS -> (SimplEnv -> SmplM OutExpr) -- Body handler -> OutType -- Type of body -> SmplM OutExpr -completeLet env binder old_rhs new_rhs body_c body_ty +completeLet env binder new_rhs body_c body_ty -- See if RHS is an atom, or a reusable constructor | maybeToBool maybe_atomic_rhs = let @@ -1158,7 +1156,7 @@ completeLet env binder old_rhs new_rhs body_c body_ty -- otherwise Nothing Just (rhs_atom, atom_tick_type) = maybe_atomic_rhs -completeLet env binder@(id,_) old_rhs new_rhs body_c body_ty +completeLet env binder@(id,_) new_rhs body_c body_ty -- Maybe the rhs is an application of error, and sure to be demanded | will_be_demanded && maybeToBool maybe_error_app @@ -1170,7 +1168,7 @@ completeLet env binder@(id,_) old_rhs new_rhs body_c body_ty Just retyped_error_app = maybe_error_app {- -completeLet env binder old_rhs (Coerce coercion ty rhs) body_c body_ty +completeLet env binder (Coerce coercion ty rhs) body_c body_ty -- Rhs is a coercion | maybeToBool maybe_atomic_coerce_rhs = tick tick_type `thenSmpl_` @@ -1193,7 +1191,7 @@ completeLet env binder old_rhs (Coerce coercion ty rhs) body_c body_ty returnSmpl (Let (NonRec id' (Coerce coercion ty rhs) body') -} -completeLet env binder old_rhs new_rhs body_c body_ty +completeLet env binder new_rhs body_c body_ty -- The general case = cloneId env binder `thenSmpl` \ id' -> let diff --git a/ghc/compiler/simplStg/LambdaLift.lhs b/ghc/compiler/simplStg/LambdaLift.lhs index b1c83dd..0562a29 100644 --- a/ghc/compiler/simplStg/LambdaLift.lhs +++ b/ghc/compiler/simplStg/LambdaLift.lhs @@ -198,7 +198,7 @@ liftExpr (StgLetNoEscape _ _ (StgNonRec binder rhs) body) liftExpr (StgLetNoEscape _ _ (StgRec pairs) body) = liftExpr body `thenLM` \ (body', body_info) -> mapAndUnzipLM dontLiftRhs rhss `thenLM` \ (rhss', rhs_infos) -> - returnLM (StgLet (StgRec (binders `zipEqual` rhss')) body', + returnLM (StgLet (StgRec (zipEqual "liftExpr" binders rhss')) body', foldr unionLiftInfo body_info rhs_infos) where (binders,rhss) = unzip pairs @@ -240,7 +240,7 @@ liftExpr (StgLet (StgRec pairs) body) | not (all isLiftableRec rhss) = liftExpr body `thenLM` \ (body', body_info) -> mapAndUnzipLM dontLiftRhs rhss `thenLM` \ (rhss', rhs_infos) -> - returnLM (StgLet (StgRec (binders `zipEqual` rhss')) body', + returnLM (StgLet (StgRec (zipEqual "liftExpr2" binders rhss')) body', foldr unionLiftInfo body_info rhs_infos) | otherwise -- All rhss are liftable diff --git a/ghc/compiler/simplStg/SatStgRhs.lhs b/ghc/compiler/simplStg/SatStgRhs.lhs index c8d2144..eab32d0 100644 --- a/ghc/compiler/simplStg/SatStgRhs.lhs +++ b/ghc/compiler/simplStg/SatStgRhs.lhs @@ -71,7 +71,7 @@ import Id ( idType, getIdArity, addIdArity, mkSysLocal, ) import IdInfo ( arityMaybe ) import SrcLoc ( mkUnknownSrcLoc ) -import Type ( splitSigmaTy, splitForAllTy, splitFunTyWithDictsAsArgs ) +import Type ( splitSigmaTy, splitForAllTy, splitFunTyExpandingDicts ) import UniqSupply ( returnUs, thenUs, mapUs, getUnique, UniqSM(..) ) import Util ( panic, assertPanic ) @@ -167,7 +167,7 @@ satRhs top env (b, StgRhsClosure cc bi fv u args body) -- get type info for this function: (_, rho_ty) = splitForAllTy (idType b) - (all_arg_tys, _) = splitFunTyWithDictsAsArgs rho_ty + (all_arg_tys, _) = splitFunTyExpandingDicts rho_ty -- now, we already have "args"; we drop that many types args_we_dont_have_tys = drop num_args all_arg_tys diff --git a/ghc/compiler/simplStg/StgSATMonad.lhs b/ghc/compiler/simplStg/StgSATMonad.lhs index 57fff4d..dd6379c 100644 --- a/ghc/compiler/simplStg/StgSATMonad.lhs +++ b/ghc/compiler/simplStg/StgSATMonad.lhs @@ -90,7 +90,7 @@ saTransform binder rhs where -- get type info for the local function: (tv_tmpl, dict_tys, tau_ty) = (splitSigmaTy . idType) binder - (reg_arg_tys, res_type) = splitTyArgs tau_ty + (reg_arg_tys, res_type) = splitFunTy tau_ty -- now, we drop the ones that are -- static, that is, the ones we will not pass to the local function diff --git a/ghc/compiler/simplStg/UpdAnal.lhs b/ghc/compiler/simplStg/UpdAnal.lhs index 5f6092c..e0f4adf 100644 --- a/ghc/compiler/simplStg/UpdAnal.lhs +++ b/ghc/compiler/simplStg/UpdAnal.lhs @@ -21,7 +21,7 @@ > updateAnalyse = panic "UpdAnal.updateAnalyse" > > {- LATER: to end of file: -> --import Type ( splitTyArgs, splitSigmaTy, Class, TyVarTemplate, +> --import Type ( splitFunTy, splitSigmaTy, Class, TyVarTemplate, > -- TauType(..) > -- ) > --import Id @@ -489,7 +489,7 @@ Convert a Closure into a representation that can be placed in a .hi file. > (combine_IdEnvs (+) c' c, b', f') > > (_,dict_tys,tau_ty) = (splitSigmaTy . idType) v -> (reg_arg_tys, _) = splitTyArgs tau_ty +> (reg_arg_tys, _) = splitFunTy tau_ty > arity = length dict_tys + length reg_arg_tys removeSuperfluous2s = reverse . dropWhile (> 1) . reverse diff --git a/ghc/compiler/specialise/SpecUtils.lhs b/ghc/compiler/specialise/SpecUtils.lhs index 990e8b2..7af0cc7 100644 --- a/ghc/compiler/specialise/SpecUtils.lhs +++ b/ghc/compiler/specialise/SpecUtils.lhs @@ -71,7 +71,7 @@ specialiseCallTys :: Bool -- Specialise on all type args specialiseCallTys True _ _ cvec tys = map Just tys specialiseCallTys False spec_unboxed spec_overloading cvec tys - = zipWithEqual spec_ty_other cvec tys + = zipWithEqual "specialiseCallTys" spec_ty_other cvec tys where spec_ty_other c ty | (spec_unboxed && isUnboxedType ty) || (spec_overloading && c) diff --git a/ghc/compiler/specialise/Specialise.lhs b/ghc/compiler/specialise/Specialise.lhs index d65eb87..4a87887 100644 --- a/ghc/compiler/specialise/Specialise.lhs +++ b/ghc/compiler/specialise/Specialise.lhs @@ -10,9 +10,7 @@ module Specialise ( specProgram, initSpecData, - SpecialiseData(..), - FiniteMap, Bag - + SpecialiseData(..) ) where import Ubiq{-uitous-} @@ -57,7 +55,7 @@ import Pretty ( ppHang, ppCat, ppStr, ppAboves, ppBesides, ) import PrimOp ( PrimOp(..) ) import SpecUtils -import Type ( mkTyVarTy, mkTyVarTys, isTyVarTy, getAppDataTyCon, +import Type ( mkTyVarTy, mkTyVarTys, isTyVarTy, getAppDataTyConExpandingDicts, tyVarsOfTypes, applyTypeEnvToTy, isUnboxedType ) import TyCon ( TyCon{-instance Eq-} ) @@ -69,8 +67,8 @@ import TyVar ( cloneTyVar, import Unique ( Unique{-instance Eq-} ) import UniqSet ( mkUniqSet, unionUniqSets, uniqSetToList ) import UniqSupply ( splitUniqSupply, getUniques, getUnique ) -import Util ( equivClasses, mapAccumL, assoc, zipWithEqual, - panic, pprTrace, pprPanic, assertPanic +import Util ( equivClasses, mapAccumL, assoc, zipEqual, zipWithEqual, + thenCmp, panic, pprTrace, pprPanic, assertPanic ) infixr 9 `thenSM` @@ -721,7 +719,7 @@ Comparisons are based on the {\em types}, ignoring the dictionary args: cmpCI :: CallInstance -> CallInstance -> TAG_ cmpCI (CallInstance id1 tys1 _ _ _) (CallInstance id2 tys2 _ _ _) - = case (id1 `cmp` id2) of { EQ_ -> cmpUniTypeMaybeList tys1 tys2; other -> other } + = cmp id1 id2 `thenCmp` cmpUniTypeMaybeList tys1 tys2 cmpCI_tys :: CallInstance -> CallInstance -> TAG_ cmpCI_tys (CallInstance _ tys1 _ _ _) (CallInstance _ tys2 _ _ _) @@ -866,7 +864,7 @@ data TyConInstance cmpTyConI :: TyConInstance -> TyConInstance -> TAG_ cmpTyConI (TyConInstance tc1 tys1) (TyConInstance tc2 tys2) - = case (cmp tc1 tc2) of { EQ_ -> cmpUniTypeMaybeList tys1 tys2; other -> other } + = cmp tc1 tc2 `thenCmp` cmpUniTypeMaybeList tys1 tys2 cmpTyConI_tys :: TyConInstance -> TyConInstance -> TAG_ cmpTyConI_tys (TyConInstance _ tys1) (TyConInstance _ tys2) @@ -1533,7 +1531,7 @@ specAlts (AlgAlts alts deflt) scrutinee_ty args -- We use ty_args of scrutinee type to identify specialisation of -- alternatives: - (_, ty_args, _) = getAppDataTyCon scrutinee_ty + (_, ty_args, _) = getAppDataTyConExpandingDicts scrutinee_ty specAlgAlt ty_args (con,binders,rhs) = specLambdaOrCaseBody binders rhs args `thenSM` \ (binders, rhs, rhs_uds) -> @@ -2414,7 +2412,7 @@ newSpecIds :: [Id] -- The id of which to make a specialised version newSpecIds new_ids maybe_tys dicts_to_ignore tvenv idenv us = [ mkSpecId uniq id maybe_tys (spec_id_ty id) (selectIdInfoForSpecId id) - | (id,uniq) <- new_ids `zip` uniqs ] + | (id,uniq) <- zipEqual "newSpecIds" new_ids uniqs ] where uniqs = getUniques (length new_ids) us spec_id_ty id = specialiseTy (idType id) maybe_tys dicts_to_ignore @@ -2446,7 +2444,7 @@ cloneLambdaOrCaseBinders old_ids tvenv idenv us = let uniqs = getUniques (length old_ids) us in - unzip (zipWithEqual clone_it old_ids uniqs) + unzip (zipWithEqual "cloneLambdaOrCaseBinders" clone_it old_ids uniqs) where clone_it old_id uniq = (new_id, NoLift (VarArg new_id)) diff --git a/ghc/compiler/stgSyn/CoreToStg.lhs b/ghc/compiler/stgSyn/CoreToStg.lhs index 233cca7..3ed0d38 100644 --- a/ghc/compiler/stgSyn/CoreToStg.lhs +++ b/ghc/compiler/stgSyn/CoreToStg.lhs @@ -37,7 +37,7 @@ import PrelInfo ( unpackCStringId, unpackCString2Id, stringTy, import PrimOp ( PrimOp(..) ) import SpecUtils ( mkSpecialisedCon ) import SrcLoc ( mkUnknownSrcLoc ) -import Type ( getAppDataTyCon ) +import Type ( getAppDataTyConExpandingDicts ) import UniqSupply -- all of it, really import Util ( panic ) @@ -543,7 +543,7 @@ coreExprToStg env (Case discrim alts) ) where discrim_ty = coreExprType discrim - (_, discrim_ty_args, _) = getAppDataTyCon discrim_ty + (_, discrim_ty_args, _) = getAppDataTyConExpandingDicts discrim_ty alts_to_stg discrim (AlgAlts alts deflt) = default_to_stg discrim deflt `thenUs` \ (stg_deflt, deflt_binds) -> diff --git a/ghc/compiler/stgSyn/StgLint.lhs b/ghc/compiler/stgSyn/StgLint.lhs index 8c7c7db..48263f5 100644 --- a/ghc/compiler/stgSyn/StgLint.lhs +++ b/ghc/compiler/stgSyn/StgLint.lhs @@ -27,14 +27,13 @@ import PprType ( GenType{-instance Outputable-}, TyCon ) import Pretty -- quite a bit of it import PrimOp ( primOpType ) import SrcLoc ( SrcLoc{-instance Outputable-} ) -import Type ( mkFunTys, splitFunTy, maybeAppDataTyCon, - isTyVarTy, eqTy +import Type ( mkFunTys, splitFunTy, maybeAppDataTyConExpandingDicts, + isTyVarTy, eqTy, splitFunTyExpandingDicts ) import Util ( zipEqual, pprPanic, panic, panic# ) infixr 9 `thenL`, `thenL_`, `thenMaybeL`, `thenMaybeL_` -splitTypeWithDictsAsArgs = panic "StgLint.splitTypeWithDictsAsArgs (ToDo)" unDictifyTy = panic "StgLint.unDictifyTy (ToDo)" \end{code} @@ -180,7 +179,7 @@ lintStgExpr e@(StgCase scrut _ _ _ alts) = lintStgExpr scrut `thenMaybeL` \ _ -> -- Check that it is a data type - case maybeAppDataTyCon scrut_ty of + case (maybeAppDataTyConExpandingDicts scrut_ty) of Nothing -> addErrL (mkCaseDataConMsg e) `thenL_` returnL Nothing Just (tycon, _, _) @@ -220,7 +219,7 @@ lintStgAlts alts scrut_ty case_tycon check ty = checkTys first_ty ty (mkCaseAltMsg alts) lintAlgAlt scrut_ty (con, args, _, rhs) - = (case maybeAppDataTyCon scrut_ty of + = (case maybeAppDataTyConExpandingDicts scrut_ty of Nothing -> addErrL (mkAlgAltMsg1 scrut_ty) Just (tycon, tys_applied, cons) -> @@ -230,7 +229,7 @@ lintAlgAlt scrut_ty (con, args, _, rhs) checkL (con `elem` cons) (mkAlgAltMsg2 scrut_ty con) `thenL_` checkL (length arg_tys == length args) (mkAlgAltMsg3 con args) `thenL_` - mapL check (arg_tys `zipEqual` args) `thenL_` + mapL check (zipEqual "lintAlgAlt:stg" arg_tys args) `thenL_` returnL () ) `thenL_` addInScopeVars args ( @@ -397,7 +396,7 @@ checkFunApp :: Type -- The function type checkFunApp fun_ty arg_tys msg loc scope errs = cfa res_ty expected_arg_tys arg_tys where - (_, expected_arg_tys, res_ty) = splitTypeWithDictsAsArgs fun_ty + (expected_arg_tys, res_ty) = splitFunTyExpandingDicts fun_ty cfa res_ty expected [] -- Args have run out; that's fine = (Just (mkFunTys expected res_ty), errs) @@ -523,13 +522,12 @@ pp_expr sty expr = ppr sty expr sleazy_eq_ty ty1 ty2 -- NB: probably severe overkill (WDP 95/04) - = case (splitTypeWithDictsAsArgs ty1) of { (_,tyargs1,tyres1) -> - case (splitTypeWithDictsAsArgs ty2) of { (_,tyargs2,tyres2) -> + = _trace "StgLint.sleazy_eq_ty:use eqSimplTy?" $ + case (splitFunTyExpandingDicts ty1) of { (tyargs1,tyres1) -> + case (splitFunTyExpandingDicts ty2) of { (tyargs2,tyres2) -> let ty11 = mkFunTys tyargs1 tyres1 ty22 = mkFunTys tyargs2 tyres2 in - trace "StgLint.sleazy_cmp_ty" $ - ty11 `eqTy` ty22 - }} + ty11 `eqTy` ty22 }} \end{code} diff --git a/ghc/compiler/stranal/SaAbsInt.lhs b/ghc/compiler/stranal/SaAbsInt.lhs index 60c943e..cc26fab 100644 --- a/ghc/compiler/stranal/SaAbsInt.lhs +++ b/ghc/compiler/stranal/SaAbsInt.lhs @@ -39,7 +39,7 @@ import SaLib import TyCon ( maybeTyConSingleCon, isEnumerationTyCon, TyCon{-instance Eq-} ) -import Type ( maybeAppDataTyCon, isPrimType ) +import Type ( maybeAppDataTyConExpandingDicts, isPrimType ) import Util ( isIn, isn'tIn, nOfThem, zipWithEqual, pprTrace, panic, pprPanic, assertPanic ) @@ -63,7 +63,7 @@ lub val1 val2 | isBot val2 = val1 -- one of the val's is a function which -- always returns bottom, such as \y.x, -- when x is bound to bottom. -lub (AbsProd xs) (AbsProd ys) = AbsProd (zipWithEqual lub xs ys) +lub (AbsProd xs) (AbsProd ys) = AbsProd (zipWithEqual "lub" lub xs ys) lub _ _ = AbsTop -- Crude, but conservative -- The crudity only shows up if there @@ -119,7 +119,7 @@ glb v1 v2 -- The non-functional cases are quite straightforward -glb (AbsProd xs) (AbsProd ys) = AbsProd (zipWithEqual glb xs ys) +glb (AbsProd xs) (AbsProd ys) = AbsProd (zipWithEqual "glb" glb xs ys) glb AbsTop v2 = v2 glb v1 AbsTop = v1 @@ -308,7 +308,7 @@ sameVal AbsBot other = False -- widen has reduced AbsFun bots to AbsBot sameVal AbsTop AbsTop = True sameVal AbsTop other = False -- Right? -sameVal (AbsProd vals1) (AbsProd vals2) = and (zipWithEqual sameVal vals1 vals2) +sameVal (AbsProd vals1) (AbsProd vals2) = and (zipWithEqual "sameVal" sameVal vals1 vals2) sameVal (AbsProd _) AbsTop = False sameVal (AbsProd _) AbsBot = False @@ -338,7 +338,7 @@ evalStrictness (WwUnpack demand_info) val = case val of AbsTop -> False AbsBot -> True - AbsProd vals -> or (zipWithEqual evalStrictness demand_info vals) + AbsProd vals -> or (zipWithEqual "evalStrictness" evalStrictness demand_info vals) _ -> trace "evalStrictness?" False evalStrictness WwPrim val @@ -363,7 +363,7 @@ evalAbsence (WwUnpack demand_info) val = case val of AbsTop -> False -- No poison in here AbsBot -> True -- Pure poison - AbsProd vals -> or (zipWithEqual evalAbsence demand_info vals) + AbsProd vals -> or (zipWithEqual "evalAbsence" evalAbsence demand_info vals) _ -> panic "evalAbsence: other" evalAbsence other val = anyBot val @@ -841,7 +841,7 @@ findRecDemand strflags seen str_fn abs_fn ty else -- It's strict (or we're pretending it is)! - case maybeAppDataTyCon ty of + case (maybeAppDataTyConExpandingDicts ty) of Nothing -> wwStrict @@ -882,7 +882,7 @@ findRecDemand strflags seen str_fn abs_fn ty (all_strict, num_strict) = strflags is_numeric_type ty - = case (maybeAppDataTyCon ty) of -- NB: duplicates stuff done above + = case (maybeAppDataTyConExpandingDicts ty) of -- NB: duplicates stuff done above Nothing -> False Just (tycon, _, _) | tycon `is_elem` diff --git a/ghc/compiler/stranal/StrictAnal.lhs b/ghc/compiler/stranal/StrictAnal.lhs index 3eb079b..71c6e90 100644 --- a/ghc/compiler/stranal/StrictAnal.lhs +++ b/ghc/compiler/stranal/StrictAnal.lhs @@ -224,7 +224,7 @@ saTopBind str_env abs_env (Rec pairs) -- fixpoint returns widened values new_str_env = growAbsValEnvList str_env (binders `zip` str_rhss) new_abs_env = growAbsValEnvList abs_env (binders `zip` abs_rhss) - new_binders = zipWith4Equal (addStrictnessInfoToId strflags) + new_binders = zipWith4Equal "saTopBind" (addStrictnessInfoToId strflags) str_rhss abs_rhss binders rhss in mapSa (saExpr new_str_env new_abs_env) rhss `thenSa` \ new_rhss -> @@ -354,7 +354,7 @@ saExpr str_env abs_env (Let (Rec pairs) body) -- deciding that y is absent, which is plain wrong! -- It's much easier simply not to do this. - improved_binders = zipWith4Equal (addStrictnessInfoToId strflags) + improved_binders = zipWith4Equal "saExpr" (addStrictnessInfoToId strflags) str_vals abs_vals binders rhss whiter_than_white_binders = launder improved_binders diff --git a/ghc/compiler/stranal/WwLib.lhs b/ghc/compiler/stranal/WwLib.lhs index a7dd9e3..ceea5e7 100644 --- a/ghc/compiler/stranal/WwLib.lhs +++ b/ghc/compiler/stranal/WwLib.lhs @@ -20,7 +20,7 @@ import IdInfo ( mkStrictnessInfo, nonAbsentArgs, Demand(..) ) import PrelInfo ( aBSENT_ERROR_ID ) import SrcLoc ( mkUnknownSrcLoc ) import Type ( isPrimType, mkTyVarTys, mkForAllTys, mkFunTys, - maybeAppDataTyCon + maybeAppDataTyConExpandingDicts ) import UniqSupply ( returnUs, thenUs, thenMaybeUs, getUniques, UniqSM(..) @@ -309,8 +309,9 @@ mk_ww_arg_processing (arg : args) (WwLazy True : infos) max_extra_args mk_ww_arg_processing (arg : args) (WwUnpack cmpnt_infos : infos) max_extra_args | new_max_extra_args > 0 -- Check that we are prepared to add arguments = -- this is the complicated one. - --pprTrace "Unpack; num_wrkr_args=" (ppCat [ppInt num_wrkr_args, ppStr "; new_max=", ppInt new_num_wrkr_args, ppStr "; arg=", ppr PprDebug arg, ppr PprDebug (WwUnpack cmpnt_infos)]) ( - case maybeAppDataTyCon arg_ty of + --pprTrace "Unpack; num_wrkr_args=" (ppCat [ppInt num_wrkr_args, ppStr "; new_max=", ppInt new_num_wrkr_args, ppStr "; arg=", ppr PprDebug arg, ppr PprDebug (WwUnpack cmpnt_infos)]) $ + + case (maybeAppDataTyConExpandingDicts arg_ty) of Nothing -> -- Not a data type panic "mk_ww_arg_processing: not datatype" @@ -330,7 +331,7 @@ mk_ww_arg_processing (arg : args) (WwUnpack cmpnt_infos : infos) max_extra_args getUniques (length inst_con_arg_tys) `thenUs` \ uniqs -> let - unpk_args = zipWithEqual + unpk_args = zipWithEqual "mk_ww_arg_processing" (\ u t -> mkSysLocal SLIT("upk") u t mkUnknownSrcLoc) uniqs inst_con_arg_tys in @@ -350,7 +351,6 @@ mk_ww_arg_processing (arg : args) (WwUnpack cmpnt_infos : infos) max_extra_args work_args_info, \ hole -> work_rest (mk_pk_let arg data_con tycon_arg_tys unpk_args hole) )) - --) where arg_ty = idType arg diff --git a/ghc/compiler/typecheck/GenSpecEtc.lhs b/ghc/compiler/typecheck/GenSpecEtc.lhs index 7a0fbb1..079c292 100644 --- a/ghc/compiler/typecheck/GenSpecEtc.lhs +++ b/ghc/compiler/typecheck/GenSpecEtc.lhs @@ -179,14 +179,14 @@ genBinds binder_names mono_ids bind lie sig_infos prag_info_fn let dict_tys = map tcIdType dicts_bound poly_tys = map (mkForAllTys tyvars . mkFunTys dict_tys) mono_id_types - poly_ids = zipWithEqual mk_poly binder_names poly_tys + poly_ids = zipWithEqual "genspecetc" mk_poly binder_names poly_tys mk_poly name ty = mkUserId name ty (prag_info_fn name) in -- BUILD RESULTS returnTc ( AbsBinds tyvars dicts_bound - (map TcId mono_ids `zip` map TcId poly_ids) + (zipEqual "genBinds" (map TcId mono_ids) (map TcId poly_ids)) dict_binds bind, lie', diff --git a/ghc/compiler/typecheck/Inst.lhs b/ghc/compiler/typecheck/Inst.lhs index a24e7ac..b4fc7f2 100644 --- a/ghc/compiler/typecheck/Inst.lhs +++ b/ghc/compiler/typecheck/Inst.lhs @@ -16,7 +16,7 @@ module Inst ( newDicts, newDictsAtLoc, newMethod, newMethodWithGivenTy, newOverloadedLit, - instType, tyVarsOfInst, lookupInst, + instType, tyVarsOfInst, lookupInst, lookupSimpleInst, isDict, isTyVarDict, @@ -39,7 +39,7 @@ import TcHsSyn ( TcIdOcc(..), TcExpr(..), TcIdBndr(..), import TcMonad hiding ( rnMtoTcM ) import TcEnv ( tcLookupGlobalValueByKey ) import TcType ( TcType(..), TcRhoType(..), TcMaybe, TcTyVarSet(..), - tcInstType, tcInstTcType, zonkTcType ) + tcInstType, zonkTcType ) import Bag ( emptyBag, unitBag, unionBags, unionManyBags, listToBag, consBag ) import Class ( Class(..), GenClass, ClassInstEnv(..), classInstEnv ) @@ -53,7 +53,7 @@ import Pretty import RnHsSyn ( RnName{-instance NamedThing-} ) import SpecEnv ( SpecEnv(..) ) import SrcLoc ( SrcLoc, mkUnknownSrcLoc ) -import Type ( GenType, eqSimpleTy, +import Type ( GenType, eqSimpleTy, instantiateTy, isTyVarTy, mkDictTy, splitForAllTy, splitSigmaTy, splitRhoTy, matchTy, tyVarsOfType, tyVarsOfTypes ) import TyVar ( GenTyVar ) @@ -62,7 +62,6 @@ import TysWiredIn ( intDataCon ) import Unique ( Unique, showUnique, fromRationalClassOpKey, fromIntClassOpKey, fromIntegerClassOpKey ) import Util ( panic, zipEqual, zipWithEqual, assoc, assertPanic ) - \end{code} %************************************************************************ @@ -158,7 +157,7 @@ newDicts orig theta tcGetUniques (length theta) `thenNF_Tc` \ new_uniqs -> let mk_dict u (clas, ty) = Dict u clas ty orig loc - dicts = zipWithEqual mk_dict new_uniqs theta + dicts = zipWithEqual "newDicts" mk_dict new_uniqs theta in returnNF_Tc (listToBag dicts, map instToId dicts) @@ -167,7 +166,7 @@ newDictsAtLoc orig loc theta -- Local function, similar to newDicts, = tcGetUniques (length theta) `thenNF_Tc` \ new_uniqs -> let mk_dict u (clas, ty) = Dict u clas ty orig loc - dicts = zipWithEqual mk_dict new_uniqs theta + dicts = zipWithEqual "newDictsAtLoc" mk_dict new_uniqs theta in returnNF_Tc (dicts, map instToId dicts) @@ -179,9 +178,9 @@ newMethod orig id tys = -- Get the Id type and instantiate it at the specified types (case id of RealId id -> let (tyvars, rho) = splitForAllTy (idType id) - in tcInstType (tyvars `zipEqual` tys) rho + in tcInstType (zipEqual "newMethod" tyvars tys) rho TcId id -> let (tyvars, rho) = splitForAllTy (idType id) - in tcInstTcType (tyvars `zipEqual` tys) rho + in returnNF_Tc (instantiateTy (zipEqual "newMethod(2)" tyvars tys) rho) ) `thenNF_Tc` \ rho_ty -> -- Our friend does the rest newMethodWithGivenTy orig id tys rho_ty @@ -202,8 +201,8 @@ newMethodAtLoc orig loc real_id tys -- Local function, similar to newMethod but let (tyvars,rho) = splitForAllTy (idType real_id) in - tcInstType (tyvars `zipEqual` tys) rho `thenNF_Tc` \ rho_ty -> - tcGetUnique `thenNF_Tc` \ new_uniq -> + tcInstType (zipEqual "newMethodAtLoc" tyvars tys) rho `thenNF_Tc` \ rho_ty -> + tcGetUnique `thenNF_Tc` \ new_uniq -> let meth_inst = Method new_uniq (RealId real_id) tys rho_ty orig loc in @@ -226,11 +225,15 @@ newOverloadedLit orig lit ty \begin{code} instToId :: Inst s -> TcIdOcc s instToId (Dict u clas ty orig loc) - = TcId (mkInstId u (mkDictTy clas ty) (mkLocalName u SLIT("dict") loc)) + = TcId (mkInstId u (mkDictTy clas ty) (mkLocalName u str loc)) + where + str = SLIT("d.") _APPEND_ (getLocalName clas) instToId (Method u id tys rho_ty orig loc) - = TcId (mkInstId u tau_ty (mkLocalName u (getLocalName id) loc)) + = TcId (mkInstId u tau_ty (mkLocalName u str loc)) where (_, tau_ty) = splitRhoTy rho_ty -- NB The method Id has just the tau type + str = SLIT("m.") _APPEND_ (getLocalName id) + instToId (LitInst u list ty orig loc) = TcId (mkInstId u ty (mkLocalName u SLIT("lit") loc)) \end{code} @@ -467,15 +470,21 @@ appropriate dictionary if it exists. It is used only when resolving ambiguous dictionaries. \begin{code} -lookupClassInstAtSimpleType :: Class -> Type -> Maybe Id - -lookupClassInstAtSimpleType clas ty - = case (lookupMEnv matchTy (classInstEnv clas) ty) of - Nothing -> Nothing - Just (dfun,_) -> ASSERT( null tyvars && null theta ) - Just dfun - where - (tyvars, theta, _) = splitSigmaTy (idType dfun) +lookupSimpleInst :: ClassInstEnv + -> Class + -> Type -- Look up (c,t) + -> TcM s [(Class,Type)] -- Here are the needed (c,t)s + +lookupSimpleInst class_inst_env clas ty + = case (lookupMEnv matchTy class_inst_env ty) of + Nothing -> failTc (noSimpleInst clas ty) + Just (dfun,tenv) -> returnTc [(c,instantiateTy tenv t) | (c,t) <- theta] + where + (_, theta, _) = splitSigmaTy (idType dfun) + +noSimpleInst clas ty sty + = ppSep [ppStr "No instance for class", ppQuote (ppr sty clas), + ppStr "at type", ppQuote (ppr sty ty)] \end{code} @@ -551,9 +560,10 @@ data InstOrigin s | ClassDeclOrigin -- Manufactured during a class decl - | DerivingOrigin InstanceMapper - Class - TyCon +-- NO MORE! +-- | DerivingOrigin InstanceMapper +-- Class +-- TyCon -- During "deriving" operations we have an ever changing -- mapping of classes to instances, so we record it inside the @@ -569,7 +579,7 @@ data InstOrigin s -- origin information. This is a bit of a hack, but it works -- fine. (Patrick is to blame [WDP].) - | DefaultDeclOrigin -- Related to a `default' declaration +-- | DefaultDeclOrigin -- Related to a `default' declaration | ValSpecOrigin Name -- in a SPECIALIZE pragma for a value @@ -594,8 +604,8 @@ data InstOrigin s -- find a mapping from classes to envts inside the dict origin. get_inst_env :: Class -> InstOrigin s -> ClassInstEnv -get_inst_env clas (DerivingOrigin inst_mapper _ _) - = fst (inst_mapper clas) +-- get_inst_env clas (DerivingOrigin inst_mapper _ _) +-- = fst (inst_mapper clas) get_inst_env clas (InstanceSpecOrigin inst_mapper _ _) = fst (inst_mapper clas) get_inst_env clas other_orig = classInstEnv clas @@ -621,17 +631,17 @@ pprOrigin (DoOrigin) sty = ppStr "in a do statement" pprOrigin (ClassDeclOrigin) sty = ppStr "in a class declaration" -pprOrigin (DerivingOrigin _ clas tycon) sty - = ppBesides [ppStr "in a `deriving' clause; class `", - ppr sty clas, - ppStr "'; offending type `", - ppr sty tycon, - ppStr "'"] +-- pprOrigin (DerivingOrigin _ clas tycon) sty +-- = ppBesides [ppStr "in a `deriving' clause; class `", +-- ppr sty clas, +-- ppStr "'; offending type `", +-- ppr sty tycon, +-- ppStr "'"] pprOrigin (InstanceSpecOrigin _ clas ty) sty = ppBesides [ppStr "in a SPECIALIZE instance pragma; class \"", ppr sty clas, ppStr "\" type: ", ppr sty ty] -pprOrigin (DefaultDeclOrigin) sty - = ppStr "in a `default' declaration" +-- pprOrigin (DefaultDeclOrigin) sty +-- = ppStr "in a `default' declaration" pprOrigin (ValSpecOrigin name) sty = ppBesides [ppStr "in a SPECIALIZE user-pragma for `", ppr sty name, ppStr "'"] diff --git a/ghc/compiler/typecheck/TcBinds.lhs b/ghc/compiler/typecheck/TcBinds.lhs index 21be195..b4d87a7 100644 --- a/ghc/compiler/typecheck/TcBinds.lhs +++ b/ghc/compiler/typecheck/TcBinds.lhs @@ -43,7 +43,7 @@ import RnHsSyn ( RnName ) -- instances import Type ( mkTyVarTy, mkTyVarTys, isTyVarTy, mkSigmaTy, splitSigmaTy, splitRhoTy, mkForAllTy, splitForAllTy ) -import Util ( isIn, panic ) +import Util ( isIn, zipEqual, panic ) \end{code} %************************************************************************ @@ -267,7 +267,7 @@ data SigInfo more_sig_infos = [ SigInfo binder (mk_poly binder local_id) local_id tys_to_gen dicts_to_gen lie_to_gen - | (binder, local_id) <- nosig_binders `zipEqual` nosig_local_ids + | (binder, local_id) <- zipEqual "???" nosig_binders nosig_local_ids ] all_sig_infos = sig_infos ++ more_sig_infos -- Contains a "signature" for each binder @@ -296,7 +296,7 @@ data SigInfo `thenTc` \ (lie_free, dict_binds) -> returnTc (AbsBind tyvars_to_gen_here dicts - (local_ids `zipEqual` poly_ids) + (zipEqual "gen_bind" local_ids poly_ids) (dict_binds ++ local_binds) bind, lie_free) diff --git a/ghc/compiler/typecheck/TcClassDcl.lhs b/ghc/compiler/typecheck/TcClassDcl.lhs index a4c43af..d2a63ba 100644 --- a/ghc/compiler/typecheck/TcClassDcl.lhs +++ b/ghc/compiler/typecheck/TcClassDcl.lhs @@ -23,7 +23,7 @@ import RnHsSyn ( RenamedClassDecl(..), RenamedClassPragmas(..), RnName{-instance Uniquable-} ) import TcHsSyn ( TcIdOcc(..), TcHsBinds(..), TcMonoBinds(..), TcExpr(..), - mkHsTyApp, mkHsTyLam, mkHsDictApp, mkHsDictLam, unZonkId ) + mkHsTyApp, mkHsTyLam, mkHsDictApp, mkHsDictLam ) import TcMonad hiding ( rnMtoTcM ) import Inst ( Inst, InstOrigin(..), LIE(..), emptyLIE, plusLIE, newDicts ) @@ -118,7 +118,8 @@ tcClassContext rec_class rec_tyvar context pragmas -- Make super-class selector ids mapTc (mk_super_id rec_class) - (super_classes `zip` maybe_pragmas) `thenTc` \ sc_sel_ids -> + (super_classes `zip` maybe_pragmas) `thenTc` \ sc_sel_ids -> + -- NB: we worry about matching list lengths below -- Done returnTc (super_classes, sc_sel_ids) @@ -312,8 +313,8 @@ buildSelectors clas clas_tyvar clas_tc_tyvar scs sc_sel_ids ops op_sel_ids mk_sel sel_id method_or_dict = mkSelBind sel_id clas_tc_tyvar clas_dict dict_ids method_ids method_or_dict in - listNF_Tc (zipWithEqual mk_sel op_sel_ids method_ids) `thenNF_Tc` \ op_sel_binds -> - listNF_Tc (zipWithEqual mk_sel sc_sel_ids dict_ids) `thenNF_Tc` \ sc_sel_binds -> + listNF_Tc (zipWithEqual "mk_sel1" mk_sel op_sel_ids method_ids) `thenNF_Tc` \ op_sel_binds -> + listNF_Tc (zipWithEqual "mk_sel2" mk_sel sc_sel_ids dict_ids) `thenNF_Tc` \ sc_sel_binds -> returnNF_Tc (SingleBind ( NonRecBind ( @@ -474,13 +475,12 @@ buildDefaultMethodBinds buildDefaultMethodBinds clas clas_tyvar default_method_ids default_binds = -- Deal with the method declarations themselves - mapNF_Tc unZonkId default_method_ids `thenNF_Tc` \ tc_defm_ids -> processInstBinds clas (makeClassDeclDefaultMethodRhs clas default_method_ids) [] -- No tyvars in scope for "this inst decl" emptyLIE -- No insts available - (map TcId tc_defm_ids) + (map RealId default_method_ids) default_binds `thenTc` \ (dicts_needed, default_binds') -> returnTc (dicts_needed, SingleBind (NonRecBind default_binds')) diff --git a/ghc/compiler/typecheck/TcDefaults.lhs b/ghc/compiler/typecheck/TcDefaults.lhs index 0296080..d714ddd 100644 --- a/ghc/compiler/typecheck/TcDefaults.lhs +++ b/ghc/compiler/typecheck/TcDefaults.lhs @@ -47,8 +47,8 @@ tcDefaults [DefaultDecl mono_tys locn] -- We only care about whether it worked or not tcLookupClassByKey numClassKey `thenNF_Tc` \ num -> - tcSimplifyCheckThetas DefaultDeclOrigin - [ (num, ty) | ty <- tau_tys ] `thenTc` \ _ -> + tcSimplifyCheckThetas + [ (num, ty) | ty <- tau_tys ] `thenTc_` returnTc tau_tys diff --git a/ghc/compiler/typecheck/TcDeriv.lhs b/ghc/compiler/typecheck/TcDeriv.lhs index 778a28a..5e7d91e 100644 --- a/ghc/compiler/typecheck/TcDeriv.lhs +++ b/ghc/compiler/typecheck/TcDeriv.lhs @@ -46,12 +46,14 @@ import TyCon ( tyConTyVars, tyConDataCons, tyConDerivings, maybeTyConSingleCon, isEnumerationTyCon, TyCon ) import Type ( GenType(..), TauType(..), mkTyVarTys, applyTyCon, mkSigmaTy, mkDictTy, isPrimType, instantiateTy, - getAppTyCon, getAppDataTyCon ) + getAppTyCon, getAppDataTyCon + ) import TyVar ( GenTyVar ) import UniqFM ( emptyUFM ) import Unique -- Keys stuff import Util ( zipWithEqual, zipEqual, sortLt, removeDups, - thenCmp, cmpList, panic, pprPanic, pprPanic# ) + thenCmp, cmpList, panic, pprPanic, pprPanic# + ) \end{code} %************************************************************************ @@ -317,7 +319,7 @@ makeDerivEqns ] where (con_tyvars, _, arg_tys, _) = dataConSig data_con - inst_env = con_tyvars `zipEqual` tyvar_tys + inst_env = zipEqual "mk_eqn" con_tyvars tyvar_tys -- same number of tyvars in data constr and type constr! \end{code} @@ -417,7 +419,7 @@ add_solns inst_infos_in eqns solns = buildInstanceEnvs all_inst_infos `thenTc` \ inst_mapper -> returnTc (new_inst_infos, inst_mapper) where - new_inst_infos = zipWithEqual mk_deriv_inst_info eqns solns + new_inst_infos = zipWithEqual "add_solns" mk_deriv_inst_info eqns solns all_inst_infos = inst_infos_in `unionBags` listToBag new_inst_infos @@ -519,7 +521,7 @@ gen_inst_info modname fixities deriver_rn_env = -- Generate the various instance-related Ids mkInstanceRelatedIds - True {-from_here-} modname + True {-from_here-} locn modname NoInstancePragmas clas tyvars ty inst_decl_theta diff --git a/ghc/compiler/typecheck/TcEnv.lhs b/ghc/compiler/typecheck/TcEnv.lhs index ba1bcbf..7702e31 100644 --- a/ghc/compiler/typecheck/TcEnv.lhs +++ b/ghc/compiler/typecheck/TcEnv.lhs @@ -10,6 +10,7 @@ module TcEnv( tcExtendTyConEnv, tcLookupTyCon, tcLookupTyConByKey, tcExtendClassEnv, tcLookupClass, tcLookupClassByKey, + tcGetTyConsAndClasses, tcExtendGlobalValEnv, tcExtendLocalValEnv, tcLookupLocalValue, tcLookupLocalValueOK, tcLookupLocalValueByKey, @@ -43,7 +44,9 @@ import RnHsSyn ( RnName(..) ) import Type ( splitForAllTy ) import Unique ( pprUnique10, pprUnique{-ToDo:rm-} ) import UniqFM -import Util ( zipWithEqual, zipWith3Equal, zipLazy, panic, pprPanic, pprTrace{-ToDo:rm-} ) +import Util ( zipEqual, zipWithEqual, zipWith3Equal, zipLazy, + panic, pprPanic, pprTrace{-ToDo:rm-} + ) \end{code} Data type declarations @@ -87,7 +90,7 @@ tcTyVarScopeGivenKinds names kinds thing_inside tcGetEnv `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) -> let - tve' = addListToUFM tve (names `zip` (kinds `zipLazy` rec_tyvars)) + tve' = addListToUFM tve (zipEqual "tcTyVarScopeGivenKinds" names (kinds `zipLazy` rec_tyvars)) in tcSetEnv (TcEnv tve' tce ce gve lve gtvs) (thing_inside rec_tyvars) `thenTc` \ result -> @@ -97,7 +100,7 @@ tcTyVarScopeGivenKinds names kinds thing_inside -- Construct the real TyVars let - tyvars = zipWithEqual mk_tyvar names kinds' + tyvars = zipWithEqual "tcTyVarScopeGivenKinds" mk_tyvar names kinds' mk_tyvar name kind = mkTyVar name (uniqueOf name) kind in returnTc (tyvars, result) @@ -124,8 +127,8 @@ tcExtendTyConEnv names_w_arities tycons scope tcGetEnv `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) -> let tce' = addListToUFM tce [ (name, (kind, arity, tycon)) - | ((name,arity), (kind,tycon)) <- names_w_arities `zip` - (kinds `zipLazy` tycons) + | ((name,arity), (kind,tycon)) + <- zipEqual "tcExtendTyConEnv" names_w_arities (kinds `zipLazy` tycons) ] in tcSetEnv (TcEnv tve tce' ce gve lve gtvs) scope `thenTc` \ result -> @@ -138,7 +141,7 @@ tcExtendClassEnv names classes scope = newKindVars (length names) `thenNF_Tc` \ kinds -> tcGetEnv `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) -> let - ce' = addListToUFM ce (names `zip` (kinds `zipLazy` classes)) + ce' = addListToUFM ce (zipEqual "tcExtendClassEnv" names (kinds `zipLazy` classes)) in tcSetEnv (TcEnv tve tce ce' gve lve gtvs) scope `thenTc` \ result -> mapNF_Tc tcDefaultKind kinds `thenNF_Tc_` @@ -184,6 +187,12 @@ tcLookupClassByKey uniq uniq in returnNF_Tc clas + +tcGetTyConsAndClasses :: NF_TcM s ([TyCon], [Class]) +tcGetTyConsAndClasses + = tcGetEnv `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) -> + returnNF_Tc ([tc | (_, _, tc) <- eltsUFM tce], + [c | (_, c) <- eltsUFM ce]) \end{code} @@ -202,7 +211,7 @@ tcExtendLocalValEnv names ids scope = tcGetEnv `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) -> tcReadMutVar gtvs `thenNF_Tc` \ global_tvs -> let - lve' = addListToUFM lve (names `zip` ids) + lve' = addListToUFM lve (zipEqual "tcExtendLocalValEnv" names ids) extra_global_tyvars = tyVarsOfTypes (map idType ids) new_global_tyvars = global_tvs `unionTyVarSets` extra_global_tyvars in @@ -281,7 +290,7 @@ newMonoIds names kind m = newTyVarTys no_of_names kind `thenNF_Tc` \ tys -> tcGetUniques no_of_names `thenNF_Tc` \ uniqs -> let - new_ids = zipWith3Equal mk_id names uniqs tys + new_ids = zipWith3Equal "newMonoIds" mk_id names uniqs tys mk_id name uniq ty = let @@ -304,7 +313,7 @@ newLocalIds names tys = tcGetSrcLoc `thenNF_Tc` \ loc -> tcGetUniques (length names) `thenNF_Tc` \ uniqs -> let - new_ids = zipWith3Equal mk_id names uniqs tys + new_ids = zipWith3Equal "newLocalIds" mk_id names uniqs tys mk_id name uniq ty = TcId (mkUserLocal name uniq ty loc) in returnNF_Tc new_ids diff --git a/ghc/compiler/typecheck/TcExpr.lhs b/ghc/compiler/typecheck/TcExpr.lhs index c5d9e36..594653b 100644 --- a/ghc/compiler/typecheck/TcExpr.lhs +++ b/ghc/compiler/typecheck/TcExpr.lhs @@ -37,7 +37,7 @@ import TcMonoType ( tcPolyType ) import TcPat ( tcPat ) import TcSimplify ( tcSimplifyAndCheck, tcSimplifyRank2 ) import TcType ( TcType(..), TcMaybe(..), - tcInstId, tcInstType, tcInstTheta, tcInstTcType, tcInstTyVars, + tcInstId, tcInstType, tcInstTheta, tcInstTyVars, newTyVarTy, zonkTcTyVars, zonkTcType ) import TcKind ( TcKind ) @@ -52,7 +52,7 @@ import PrelInfo ( intPrimTy, charPrimTy, doublePrimTy, boolTy, charTy, stringTy, mkListTy, mkTupleTy, mkPrimIoTy ) import Type ( mkFunTy, mkAppTy, mkTyVarTy, mkTyVarTys, - getTyVar_maybe, getFunTy_maybe, + getTyVar_maybe, getFunTy_maybe, instantiateTy, splitForAllTy, splitRhoTy, splitSigmaTy, splitFunTy, isTauTy, mkFunTys, tyVarsOfType, getForAllTy_maybe, getAppDataTyCon, maybeAppDataTyCon @@ -166,7 +166,8 @@ tcExpr (HsLit lit@(HsString str)) %************************************************************************ \begin{code} -tcExpr (HsPar expr) = tcExpr expr +tcExpr (HsPar expr) -- preserve parens so printing needn't guess where they go + = tcExpr expr tcExpr (NegApp expr n) = tcExpr (HsApp (HsVar n) expr) @@ -261,8 +262,8 @@ tcExpr (CCall lbl args may_gc is_asm ignored_fake_result_ty) -- Construct the extra insts, which encode the -- constraints on the argument and result types. - mapNF_Tc new_arg_dict (args `zip` arg_tys) `thenNF_Tc` \ ccarg_dicts_s -> - newDicts result_origin [(cReturnableClass, result_ty)] `thenNF_Tc` \ (ccres_dict, _) -> + mapNF_Tc new_arg_dict (zipEqual "tcExpr:CCall" args arg_tys) `thenNF_Tc` \ ccarg_dicts_s -> + newDicts result_origin [(cReturnableClass, result_ty)] `thenNF_Tc` \ (ccres_dict, _) -> returnTc (CCall lbl args' may_gc is_asm result_ty, foldr plusLIE ccres_dict ccarg_dicts_s `plusLIE` args_lie, @@ -394,14 +395,14 @@ tcExpr (RecordUpd record_expr rbinds) -- Check that the field names are plausible zonkTcType record_ty `thenNF_Tc` \ record_ty' -> let - (tycon, inst_tys, data_cons) = _trace "getAppDataTyCon.TcExpr" $ getAppDataTyCon record_ty' + (tycon, inst_tys, data_cons) = _trace "TcExpr.getAppDataTyCon" $ getAppDataTyCon record_ty' -- The record binds are non-empty (syntax); so at least one field -- label will have been unified with record_ty by tcRecordBinds; -- field labels must be of data type; hencd the getAppDataTyCon must succeed. (tyvars, theta, _, _) = dataConSig (head data_cons) in - tcInstTheta (tyvars `zipEqual` inst_tys) theta `thenNF_Tc` \ theta' -> - newDicts RecordUpdOrigin theta' `thenNF_Tc` \ (con_lie, dicts) -> + tcInstTheta (zipEqual "tcExpr:RecordUpd" tyvars inst_tys) theta `thenNF_Tc` \ theta' -> + newDicts RecordUpdOrigin theta' `thenNF_Tc` \ (con_lie, dicts) -> checkTc (any (checkRecordFields rbinds) data_cons) (badFieldsUpd rbinds) `thenTc_` @@ -626,11 +627,9 @@ tcArg expected_arg_ty arg ) where - mk_binds [] - = EmptyBinds + mk_binds [] = EmptyBinds mk_binds ((inst,rhs):inst_binds) - = (SingleBind (NonRecBind (VarMonoBind inst rhs))) - `ThenBinds` + = (SingleBind (NonRecBind (VarMonoBind inst rhs))) `ThenBinds` mk_binds inst_binds \end{code} @@ -652,7 +651,9 @@ tcId name (tyvars, rho) = splitForAllTy (idType tc_id) in tcInstTyVars tyvars `thenNF_Tc` \ (tyvars', arg_tys', tenv) -> - tcInstTcType tenv rho `thenNF_Tc` \ rho' -> + let + rho' = instantiateTy tenv rho + in returnNF_Tc (TcId tc_id, arg_tys', rho') Nothing -> tcLookupGlobalValue name `thenNF_Tc` \ id -> diff --git a/ghc/compiler/typecheck/TcGenDeriv.lhs b/ghc/compiler/typecheck/TcGenDeriv.lhs index e631dc1..cf7eb32 100644 --- a/ghc/compiler/typecheck/TcGenDeriv.lhs +++ b/ghc/compiler/typecheck/TcGenDeriv.lhs @@ -590,7 +590,7 @@ gen_Ix_binds tycon -------------------------------------------------------------- single_con_range = mk_easy_FunMonoBind range_PN [TuplePatIn [con_pat as_needed, con_pat bs_needed]] [] ( - ListComp (con_expr cs_needed) (zipWith3Equal mk_qual as_needed bs_needed cs_needed) + ListComp (con_expr cs_needed) (zipWith3Equal "single_con_range" mk_qual as_needed bs_needed cs_needed) ) where mk_qual a b c = GeneratorQual (VarPatIn c) @@ -619,7 +619,7 @@ gen_Ix_binds tycon ------------------ single_con_inRange = mk_easy_FunMonoBind inRange_PN [TuplePatIn [con_pat as_needed, con_pat bs_needed], con_pat cs_needed] [] ( - foldl1 and_Expr (zipWith3Equal in_range as_needed bs_needed cs_needed)) + foldl1 and_Expr (zipWith3Equal "single_con_inRange" in_range as_needed bs_needed cs_needed)) where in_range a b c = HsApp (HsApp (HsVar inRange_PN) (ExplicitTuple [HsVar a, HsVar b])) (HsVar c) \end{code} @@ -666,7 +666,7 @@ gen_Read_binds fixities tycon (TuplePatIn [LitPatIn (HsString data_con_str), d_Pat]) (HsApp (HsVar lex_PN) c_Expr) - field_quals = snd (mapAccumL mk_qual d_Expr (as_needed `zip` bs_needed)) + field_quals = snd (mapAccumL mk_qual d_Expr (zipEqual "as_needed" as_needed bs_needed)) read_paren_arg = if nullary_con then -- must be False (parens are surely optional) diff --git a/ghc/compiler/typecheck/TcHsSyn.lhs b/ghc/compiler/typecheck/TcHsSyn.lhs index 3c86baf..ba69475 100644 --- a/ghc/compiler/typecheck/TcHsSyn.lhs +++ b/ghc/compiler/typecheck/TcHsSyn.lhs @@ -28,9 +28,7 @@ module TcHsSyn ( tcIdType, zonkBinds, - zonkInst, - zonkId, -- TcIdBndr s -> NF_TcM s Id - unZonkId -- Id -> NF_TcM s (TcIdBndr s) + zonkDictBinds ) where import Ubiq{-uitous-} @@ -38,21 +36,29 @@ import Ubiq{-uitous-} -- friends: import HsSyn -- oodles of it import Id ( GenId(..), IdDetails, PragmaInfo, -- Can meddle modestly with Ids - DictVar(..), idType + DictVar(..), idType, + IdEnv(..), growIdEnvList, lookupIdEnv ) -- others: +import Name ( Name{--O only-} ) import TcMonad hiding ( rnMtoTcM ) import TcType ( TcType(..), TcMaybe, TcTyVar(..), zonkTcTypeToType, zonkTcTyVarToTyVar, tcInstType ) import Usage ( UVar(..) ) -import Util ( panic ) +import Util ( zipEqual, panic, pprPanic, pprTrace ) import PprType ( GenType, GenTyVar ) -- instances -import TyVar ( GenTyVar ) -- instances +import Type ( mkTyVarTy ) +import TyVar ( GenTyVar {- instances -}, + TyVarEnv(..), growTyVarEnvList ) -- instances +import TysWiredIn ( voidTy ) import Unique ( Unique ) -- instances +import UniqFM +import PprStyle +import Pretty \end{code} @@ -114,8 +120,8 @@ mkHsDictLam [] expr = expr mkHsDictLam dicts expr = DictLam dicts expr tcIdType :: TcIdOcc s -> TcType s -tcIdType (TcId id) = idType id -tcIdType other = panic "tcIdType" +tcIdType (TcId id) = idType id +tcIdType (RealId id) = pprPanic "tcIdType:" (ppr PprDebug id) \end{code} @@ -142,100 +148,144 @@ instance NamedThing (TcIdOcc s) where %* * %************************************************************************ -\begin{code} -zonkId :: TcIdOcc s -> NF_TcM s Id -unZonkId :: Id -> NF_TcM s (TcIdBndr s) +This zonking pass runs over the bindings + + a) to convert TcTyVars to TyVars etc, dereferencing any bindings etc + b) convert unbound TcTyVar to Void -zonkId (RealId id) = returnNF_Tc id +We pass an environment around so that + a) we know which TyVars are unbound + b) we maintain sharing; eg an Id is zonked at its binding site and they + all occurrences of that Id point to the common zonked copy -zonkId (TcId (Id u ty details prags info)) - = zonkTcTypeToType ty `thenNF_Tc` \ ty' -> - returnNF_Tc (Id u ty' details prags info) +It's all pretty boring stuff, because HsSyn is such a large type, and +the environment manipulation is tiresome. -unZonkId (Id u ty details prags info) - = tcInstType [] ty `thenNF_Tc` \ ty' -> - returnNF_Tc (Id u ty' details prags info) + +\begin{code} +zonkIdBndr :: TyVarEnv Type -> TcIdOcc s -> NF_TcM s Id +zonkIdBndr te (TcId (Id u n ty details prags info)) + = zonkTcTypeToType te ty `thenNF_Tc` \ ty' -> + returnNF_Tc (Id u n ty' details prags info) + +zonkIdBndr te (RealId id) = returnNF_Tc id + +zonkIdOcc :: IdEnv Id -> TcIdOcc s -> Id +zonkIdOcc ve (RealId id) = id +zonkIdOcc ve (TcId id) = case (lookupIdEnv ve id) of + Just id' -> id' + Nothing -> pprTrace "zonkIdOcc: " (ppr PprDebug id) $ + Id u n voidTy details prags info + where + Id u n _ details prags info = id + +extend_ve ve ids = growIdEnvList ve [(id,id) | id <- ids] +extend_te te tyvars = growTyVarEnvList te [(tyvar, mkTyVarTy tyvar) | tyvar <- tyvars] \end{code} \begin{code} -zonkInst :: (TcIdOcc s, TcExpr s) -> NF_TcM s (Id, TypecheckedHsExpr) -zonkInst (id, expr) - = zonkId id `thenNF_Tc` \ id' -> - zonkExpr expr `thenNF_Tc` \ expr' -> - returnNF_Tc (id', expr') + -- Implicitly mutually recursive, which is overkill, + -- but it means that later ones see earlier ones +zonkDictBinds te ve dbs + = fixNF_Tc (\ ~(_,new_ve) -> + zonkDictBindsLocal te new_ve dbs `thenNF_Tc` \ (new_binds, dict_ids) -> + returnNF_Tc (new_binds, extend_ve ve dict_ids) + ) + + -- The ..Local version assumes the caller has set up + -- a ve that contains all the things bound here +zonkDictBindsLocal te ve [] = returnNF_Tc ([], []) + +zonkDictBindsLocal te ve ((dict,rhs) : binds) + = zonkIdBndr te dict `thenNF_Tc` \ new_dict -> + zonkExpr te ve rhs `thenNF_Tc` \ new_rhs -> + zonkDictBindsLocal te ve binds `thenNF_Tc` \ (new_binds, dict_ids) -> + returnNF_Tc ((new_dict,new_rhs) : new_binds, + new_dict:dict_ids) \end{code} \begin{code} -zonkBinds :: TcHsBinds s -> NF_TcM s TypecheckedHsBinds +zonkBinds :: TyVarEnv Type -> IdEnv Id + -> TcHsBinds s -> NF_TcM s (TypecheckedHsBinds, IdEnv Id) -zonkBinds EmptyBinds = returnNF_Tc EmptyBinds +zonkBinds te ve EmptyBinds = returnNF_Tc (EmptyBinds, ve) -zonkBinds (ThenBinds binds1 binds2) - = zonkBinds binds1 `thenNF_Tc` \ new_binds1 -> - zonkBinds binds2 `thenNF_Tc` \ new_binds2 -> - returnNF_Tc (ThenBinds new_binds1 new_binds2) +zonkBinds te ve (ThenBinds binds1 binds2) + = zonkBinds te ve binds1 `thenNF_Tc` \ (new_binds1, ve1) -> + zonkBinds te ve1 binds2 `thenNF_Tc` \ (new_binds2, ve2) -> + returnNF_Tc (ThenBinds new_binds1 new_binds2, ve2) -zonkBinds (SingleBind bind) - = zonkBind bind `thenNF_Tc` \ new_bind -> - returnNF_Tc (SingleBind new_bind) +zonkBinds te ve (SingleBind bind) + = fixNF_Tc (\ ~(_,new_ve) -> + zonkBind te new_ve bind `thenNF_Tc` \ (new_bind, new_ids) -> + returnNF_Tc (SingleBind new_bind, extend_ve ve new_ids) + ) -zonkBinds (AbsBinds tyvars dicts locprs dict_binds val_bind) +zonkBinds te ve (AbsBinds tyvars dicts locprs dict_binds val_bind) = mapNF_Tc zonkTcTyVarToTyVar tyvars `thenNF_Tc` \ new_tyvars -> - mapNF_Tc zonkId dicts `thenNF_Tc` \ new_dicts -> - mapNF_Tc subst_pair locprs `thenNF_Tc` \ new_locprs -> - mapNF_Tc subst_bind dict_binds `thenNF_Tc` \ new_dict_binds -> - zonkBind val_bind `thenNF_Tc` \ new_val_bind -> - returnNF_Tc (AbsBinds new_tyvars new_dicts new_locprs new_dict_binds new_val_bind) + let + new_te = extend_te te new_tyvars + in + mapNF_Tc (zonkIdBndr new_te) dicts `thenNF_Tc` \ new_dicts -> + mapNF_Tc (zonkIdBndr new_te) globals `thenNF_Tc` \ new_globals -> + let + ve1 = extend_ve ve new_globals + ve2 = extend_ve ve1 new_dicts + in + fixNF_Tc (\ ~(_, ve3) -> + zonkDictBindsLocal new_te ve3 dict_binds `thenNF_Tc` \ (new_dict_binds, ds) -> + zonkBind new_te ve3 val_bind `thenNF_Tc` \ (new_val_bind, ls) -> + let + new_locprs = zipEqual "zonkBinds" (map (zonkIdOcc ve3) locals) new_globals + in + returnNF_Tc (AbsBinds new_tyvars new_dicts new_locprs new_dict_binds new_val_bind, + extend_ve ve2 (ds++ls)) + ) `thenNF_Tc` \ (binds, _) -> + returnNF_Tc (binds, ve1) -- Yes, the "ve1" is right (SLPJ) where - subst_pair (l, g) - = zonkId l `thenNF_Tc` \ new_l -> - zonkId g `thenNF_Tc` \ new_g -> - returnNF_Tc (new_l, new_g) - - subst_bind (v, e) - = zonkId v `thenNF_Tc` \ new_v -> - zonkExpr e `thenNF_Tc` \ new_e -> - returnNF_Tc (new_v, new_e) + (locals, globals) = unzip locprs \end{code} \begin{code} ------------------------------------------------------------------------- -zonkBind :: TcBind s -> NF_TcM s TypecheckedBind +zonkBind :: TyVarEnv Type -> IdEnv Id + -> TcBind s -> NF_TcM s (TypecheckedBind, [Id]) -zonkBind EmptyBind = returnNF_Tc EmptyBind +zonkBind te ve EmptyBind = returnNF_Tc (EmptyBind, []) -zonkBind (NonRecBind mbinds) - = zonkMonoBinds mbinds `thenNF_Tc` \ new_mbinds -> - returnNF_Tc (NonRecBind new_mbinds) +zonkBind te ve (NonRecBind mbinds) + = zonkMonoBinds te ve mbinds `thenNF_Tc` \ (new_mbinds, new_ids) -> + returnNF_Tc (NonRecBind new_mbinds, new_ids) -zonkBind (RecBind mbinds) - = zonkMonoBinds mbinds `thenNF_Tc` \ new_mbinds -> - returnNF_Tc (RecBind new_mbinds) +zonkBind te ve (RecBind mbinds) + = zonkMonoBinds te ve mbinds `thenNF_Tc` \ (new_mbinds, new_ids) -> + returnNF_Tc (RecBind new_mbinds, new_ids) ------------------------------------------------------------------------- -zonkMonoBinds :: TcMonoBinds s -> NF_TcM s TypecheckedMonoBinds - -zonkMonoBinds EmptyMonoBinds = returnNF_Tc EmptyMonoBinds - -zonkMonoBinds (AndMonoBinds mbinds1 mbinds2) - = zonkMonoBinds mbinds1 `thenNF_Tc` \ new_mbinds1 -> - zonkMonoBinds mbinds2 `thenNF_Tc` \ new_mbinds2 -> - returnNF_Tc (AndMonoBinds new_mbinds1 new_mbinds2) - -zonkMonoBinds (PatMonoBind pat grhss_w_binds locn) - = zonkPat pat `thenNF_Tc` \ new_pat -> - zonkGRHSsAndBinds grhss_w_binds `thenNF_Tc` \ new_grhss_w_binds -> - returnNF_Tc (PatMonoBind new_pat new_grhss_w_binds locn) - -zonkMonoBinds (VarMonoBind var expr) - = zonkId var `thenNF_Tc` \ new_var -> - zonkExpr expr `thenNF_Tc` \ new_expr -> - returnNF_Tc (VarMonoBind new_var new_expr) - -zonkMonoBinds (FunMonoBind name inf ms locn) - = zonkId name `thenNF_Tc` \ new_name -> - mapNF_Tc zonkMatch ms `thenNF_Tc` \ new_ms -> - returnNF_Tc (FunMonoBind new_name inf new_ms locn) +zonkMonoBinds :: TyVarEnv Type -> IdEnv Id + -> TcMonoBinds s -> NF_TcM s (TypecheckedMonoBinds, [Id]) + +zonkMonoBinds te ve EmptyMonoBinds = returnNF_Tc (EmptyMonoBinds, []) + +zonkMonoBinds te ve (AndMonoBinds mbinds1 mbinds2) + = zonkMonoBinds te ve mbinds1 `thenNF_Tc` \ (new_mbinds1, ids1) -> + zonkMonoBinds te ve mbinds2 `thenNF_Tc` \ (new_mbinds2, ids2) -> + returnNF_Tc (AndMonoBinds new_mbinds1 new_mbinds2, ids1 ++ ids2) + +zonkMonoBinds te ve (PatMonoBind pat grhss_w_binds locn) + = zonkPat te ve pat `thenNF_Tc` \ (new_pat, ids) -> + zonkGRHSsAndBinds te ve grhss_w_binds `thenNF_Tc` \ new_grhss_w_binds -> + returnNF_Tc (PatMonoBind new_pat new_grhss_w_binds locn, ids) + +zonkMonoBinds te ve (VarMonoBind var expr) + = zonkIdBndr te var `thenNF_Tc` \ new_var -> + zonkExpr te ve expr `thenNF_Tc` \ new_expr -> + returnNF_Tc (VarMonoBind new_var new_expr, [new_var]) + +zonkMonoBinds te ve (FunMonoBind var inf ms locn) + = zonkIdBndr te var `thenNF_Tc` \ new_var -> + mapNF_Tc (zonkMatch te ve) ms `thenNF_Tc` \ new_ms -> + returnNF_Tc (FunMonoBind new_var inf new_ms locn, [new_var]) \end{code} %************************************************************************ @@ -245,39 +295,45 @@ zonkMonoBinds (FunMonoBind name inf ms locn) %************************************************************************ \begin{code} -zonkMatch :: TcMatch s -> NF_TcM s TypecheckedMatch - -zonkMatch (PatMatch pat match) - = zonkPat pat `thenNF_Tc` \ new_pat -> - zonkMatch match `thenNF_Tc` \ new_match -> +zonkMatch :: TyVarEnv Type -> IdEnv Id + -> TcMatch s -> NF_TcM s TypecheckedMatch + +zonkMatch te ve (PatMatch pat match) + = zonkPat te ve pat `thenNF_Tc` \ (new_pat, ids) -> + let + new_ve = extend_ve ve ids + in + zonkMatch te new_ve match `thenNF_Tc` \ new_match -> returnNF_Tc (PatMatch new_pat new_match) -zonkMatch (GRHSMatch grhss_w_binds) - = zonkGRHSsAndBinds grhss_w_binds `thenNF_Tc` \ new_grhss_w_binds -> +zonkMatch te ve (GRHSMatch grhss_w_binds) + = zonkGRHSsAndBinds te ve grhss_w_binds `thenNF_Tc` \ new_grhss_w_binds -> returnNF_Tc (GRHSMatch new_grhss_w_binds) -zonkMatch (SimpleMatch expr) - = zonkExpr expr `thenNF_Tc` \ new_expr -> +zonkMatch te ve (SimpleMatch expr) + = zonkExpr te ve expr `thenNF_Tc` \ new_expr -> returnNF_Tc (SimpleMatch new_expr) ------------------------------------------------------------------------- -zonkGRHSsAndBinds :: TcGRHSsAndBinds s - -> NF_TcM s TypecheckedGRHSsAndBinds - -zonkGRHSsAndBinds (GRHSsAndBindsOut grhss binds ty) - = mapNF_Tc zonk_grhs grhss `thenNF_Tc` \ new_grhss -> - zonkBinds binds `thenNF_Tc` \ new_binds -> - zonkTcTypeToType ty `thenNF_Tc` \ new_ty -> +zonkGRHSsAndBinds :: TyVarEnv Type -> IdEnv Id + -> TcGRHSsAndBinds s + -> NF_TcM s TypecheckedGRHSsAndBinds + +zonkGRHSsAndBinds te ve (GRHSsAndBindsOut grhss binds ty) + = zonkBinds te ve binds `thenNF_Tc` \ (new_binds, new_ve) -> + let + zonk_grhs (GRHS guard expr locn) + = zonkExpr te new_ve guard `thenNF_Tc` \ new_guard -> + zonkExpr te new_ve expr `thenNF_Tc` \ new_expr -> + returnNF_Tc (GRHS new_guard new_expr locn) + + zonk_grhs (OtherwiseGRHS expr locn) + = zonkExpr te new_ve expr `thenNF_Tc` \ new_expr -> + returnNF_Tc (OtherwiseGRHS new_expr locn) + in + mapNF_Tc zonk_grhs grhss `thenNF_Tc` \ new_grhss -> + zonkTcTypeToType te ty `thenNF_Tc` \ new_ty -> returnNF_Tc (GRHSsAndBindsOut new_grhss new_binds new_ty) - where - zonk_grhs (GRHS guard expr locn) - = zonkExpr guard `thenNF_Tc` \ new_guard -> - zonkExpr expr `thenNF_Tc` \ new_expr -> - returnNF_Tc (GRHS new_guard new_expr locn) - - zonk_grhs (OtherwiseGRHS expr locn) - = zonkExpr expr `thenNF_Tc` \ new_expr -> - returnNF_Tc (OtherwiseGRHS new_expr locn) \end{code} %************************************************************************ @@ -287,227 +343,253 @@ zonkGRHSsAndBinds (GRHSsAndBindsOut grhss binds ty) %************************************************************************ \begin{code} -zonkExpr :: TcExpr s -> NF_TcM s TypecheckedHsExpr +zonkExpr :: TyVarEnv Type -> IdEnv Id + -> TcExpr s -> NF_TcM s TypecheckedHsExpr -zonkExpr (HsVar name) - = zonkId name `thenNF_Tc` \ new_name -> - returnNF_Tc (HsVar new_name) +zonkExpr te ve (HsVar name) + = returnNF_Tc (HsVar (zonkIdOcc ve name)) -zonkExpr (HsLit _) = panic "zonkExpr:HsLit" +zonkExpr te ve (HsLit _) = panic "zonkExpr te ve:HsLit" -zonkExpr (HsLitOut lit ty) - = zonkTcTypeToType ty `thenNF_Tc` \ new_ty -> +zonkExpr te ve (HsLitOut lit ty) + = zonkTcTypeToType te ty `thenNF_Tc` \ new_ty -> returnNF_Tc (HsLitOut lit new_ty) -zonkExpr (HsLam match) - = zonkMatch match `thenNF_Tc` \ new_match -> +zonkExpr te ve (HsLam match) + = zonkMatch te ve match `thenNF_Tc` \ new_match -> returnNF_Tc (HsLam new_match) -zonkExpr (HsApp e1 e2) - = zonkExpr e1 `thenNF_Tc` \ new_e1 -> - zonkExpr e2 `thenNF_Tc` \ new_e2 -> +zonkExpr te ve (HsApp e1 e2) + = zonkExpr te ve e1 `thenNF_Tc` \ new_e1 -> + zonkExpr te ve e2 `thenNF_Tc` \ new_e2 -> returnNF_Tc (HsApp new_e1 new_e2) -zonkExpr (OpApp e1 op e2) - = zonkExpr e1 `thenNF_Tc` \ new_e1 -> - zonkExpr op `thenNF_Tc` \ new_op -> - zonkExpr e2 `thenNF_Tc` \ new_e2 -> +zonkExpr te ve (OpApp e1 op e2) + = zonkExpr te ve e1 `thenNF_Tc` \ new_e1 -> + zonkExpr te ve op `thenNF_Tc` \ new_op -> + zonkExpr te ve e2 `thenNF_Tc` \ new_e2 -> returnNF_Tc (OpApp new_e1 new_op new_e2) -zonkExpr (NegApp _ _) = panic "zonkExpr:NegApp" -zonkExpr (HsPar _) = panic "zonkExpr:HsPar" +zonkExpr te ve (NegApp _ _) = panic "zonkExpr te ve:NegApp" +zonkExpr te ve (HsPar _) = panic "zonkExpr te ve:HsPar" -zonkExpr (SectionL expr op) - = zonkExpr expr `thenNF_Tc` \ new_expr -> - zonkExpr op `thenNF_Tc` \ new_op -> +zonkExpr te ve (SectionL expr op) + = zonkExpr te ve expr `thenNF_Tc` \ new_expr -> + zonkExpr te ve op `thenNF_Tc` \ new_op -> returnNF_Tc (SectionL new_expr new_op) -zonkExpr (SectionR op expr) - = zonkExpr op `thenNF_Tc` \ new_op -> - zonkExpr expr `thenNF_Tc` \ new_expr -> +zonkExpr te ve (SectionR op expr) + = zonkExpr te ve op `thenNF_Tc` \ new_op -> + zonkExpr te ve expr `thenNF_Tc` \ new_expr -> returnNF_Tc (SectionR new_op new_expr) -zonkExpr (HsCase expr ms src_loc) - = zonkExpr expr `thenNF_Tc` \ new_expr -> - mapNF_Tc zonkMatch ms `thenNF_Tc` \ new_ms -> +zonkExpr te ve (HsCase expr ms src_loc) + = zonkExpr te ve expr `thenNF_Tc` \ new_expr -> + mapNF_Tc (zonkMatch te ve) ms `thenNF_Tc` \ new_ms -> returnNF_Tc (HsCase new_expr new_ms src_loc) -zonkExpr (HsIf e1 e2 e3 src_loc) - = zonkExpr e1 `thenNF_Tc` \ new_e1 -> - zonkExpr e2 `thenNF_Tc` \ new_e2 -> - zonkExpr e3 `thenNF_Tc` \ new_e3 -> +zonkExpr te ve (HsIf e1 e2 e3 src_loc) + = zonkExpr te ve e1 `thenNF_Tc` \ new_e1 -> + zonkExpr te ve e2 `thenNF_Tc` \ new_e2 -> + zonkExpr te ve e3 `thenNF_Tc` \ new_e3 -> returnNF_Tc (HsIf new_e1 new_e2 new_e3 src_loc) -zonkExpr (HsLet binds expr) - = zonkBinds binds `thenNF_Tc` \ new_binds -> - zonkExpr expr `thenNF_Tc` \ new_expr -> +zonkExpr te ve (HsLet binds expr) + = zonkBinds te ve binds `thenNF_Tc` \ (new_binds, new_ve) -> + zonkExpr te new_ve expr `thenNF_Tc` \ new_expr -> returnNF_Tc (HsLet new_binds new_expr) -zonkExpr (HsDo _ _) = panic "zonkExpr:HsDo" +zonkExpr te ve (HsDo _ _) = panic "zonkExpr te ve:HsDo" -zonkExpr (HsDoOut stmts m_id mz_id src_loc) - = zonkStmts stmts `thenNF_Tc` \ new_stmts -> - zonkId m_id `thenNF_Tc` \ m_new -> - zonkId mz_id `thenNF_Tc` \ mz_new -> +zonkExpr te ve (HsDoOut stmts m_id mz_id src_loc) + = zonkStmts te ve stmts `thenNF_Tc` \ new_stmts -> returnNF_Tc (HsDoOut new_stmts m_new mz_new src_loc) + where + m_new = zonkIdOcc ve m_id + mz_new = zonkIdOcc ve mz_id -zonkExpr (ListComp expr quals) - = zonkExpr expr `thenNF_Tc` \ new_expr -> - zonkQuals quals `thenNF_Tc` \ new_quals -> +zonkExpr te ve (ListComp expr quals) + = zonkQuals te ve quals `thenNF_Tc` \ (new_quals, new_ve) -> + zonkExpr te new_ve expr `thenNF_Tc` \ new_expr -> returnNF_Tc (ListComp new_expr new_quals) -zonkExpr (ExplicitList _) = panic "zonkExpr:ExplicitList" +zonkExpr te ve (ExplicitList _) = panic "zonkExpr te ve:ExplicitList" -zonkExpr (ExplicitListOut ty exprs) - = zonkTcTypeToType ty `thenNF_Tc` \ new_ty -> - mapNF_Tc zonkExpr exprs `thenNF_Tc` \ new_exprs -> +zonkExpr te ve (ExplicitListOut ty exprs) + = zonkTcTypeToType te ty `thenNF_Tc` \ new_ty -> + mapNF_Tc (zonkExpr te ve) exprs `thenNF_Tc` \ new_exprs -> returnNF_Tc (ExplicitListOut new_ty new_exprs) -zonkExpr (ExplicitTuple exprs) - = mapNF_Tc zonkExpr exprs `thenNF_Tc` \ new_exprs -> +zonkExpr te ve (ExplicitTuple exprs) + = mapNF_Tc (zonkExpr te ve) exprs `thenNF_Tc` \ new_exprs -> returnNF_Tc (ExplicitTuple new_exprs) -zonkExpr (RecordCon con rbinds) - = zonkExpr con `thenNF_Tc` \ new_con -> - zonkRbinds rbinds `thenNF_Tc` \ new_rbinds -> +zonkExpr te ve (RecordCon con rbinds) + = zonkExpr te ve con `thenNF_Tc` \ new_con -> + zonkRbinds te ve rbinds `thenNF_Tc` \ new_rbinds -> returnNF_Tc (RecordCon new_con new_rbinds) -zonkExpr (RecordUpd _ _) = panic "zonkExpr:RecordUpd" +zonkExpr te ve (RecordUpd _ _) = panic "zonkExpr te ve:RecordUpd" -zonkExpr (RecordUpdOut expr ids rbinds) - = zonkExpr expr `thenNF_Tc` \ new_expr -> - mapNF_Tc zonkId ids `thenNF_Tc` \ new_ids -> - zonkRbinds rbinds `thenNF_Tc` \ new_rbinds -> - returnNF_Tc (RecordUpdOut new_expr new_ids new_rbinds) +zonkExpr te ve (RecordUpdOut expr dicts rbinds) + = zonkExpr te ve expr `thenNF_Tc` \ new_expr -> + zonkRbinds te ve rbinds `thenNF_Tc` \ new_rbinds -> + returnNF_Tc (RecordUpdOut new_expr new_dicts new_rbinds) + where + new_dicts = map (zonkIdOcc ve) dicts -zonkExpr (ExprWithTySig _ _) = panic "zonkExpr:ExprWithTySig" -zonkExpr (ArithSeqIn _) = panic "zonkExpr:ArithSeqIn" +zonkExpr te ve (ExprWithTySig _ _) = panic "zonkExpr te ve:ExprWithTySig" +zonkExpr te ve (ArithSeqIn _) = panic "zonkExpr te ve:ArithSeqIn" -zonkExpr (ArithSeqOut expr info) - = zonkExpr expr `thenNF_Tc` \ new_expr -> - zonkArithSeq info `thenNF_Tc` \ new_info -> +zonkExpr te ve (ArithSeqOut expr info) + = zonkExpr te ve expr `thenNF_Tc` \ new_expr -> + zonkArithSeq te ve info `thenNF_Tc` \ new_info -> returnNF_Tc (ArithSeqOut new_expr new_info) -zonkExpr (CCall fun args may_gc is_casm result_ty) - = mapNF_Tc zonkExpr args `thenNF_Tc` \ new_args -> - zonkTcTypeToType result_ty `thenNF_Tc` \ new_result_ty -> +zonkExpr te ve (CCall fun args may_gc is_casm result_ty) + = mapNF_Tc (zonkExpr te ve) args `thenNF_Tc` \ new_args -> + zonkTcTypeToType te result_ty `thenNF_Tc` \ new_result_ty -> returnNF_Tc (CCall fun new_args may_gc is_casm new_result_ty) -zonkExpr (HsSCC label expr) - = zonkExpr expr `thenNF_Tc` \ new_expr -> +zonkExpr te ve (HsSCC label expr) + = zonkExpr te ve expr `thenNF_Tc` \ new_expr -> returnNF_Tc (HsSCC label new_expr) -zonkExpr (TyLam tyvars expr) +zonkExpr te ve (TyLam tyvars expr) = mapNF_Tc zonkTcTyVarToTyVar tyvars `thenNF_Tc` \ new_tyvars -> - zonkExpr expr `thenNF_Tc` \ new_expr -> + let + new_te = extend_te te new_tyvars + in + zonkExpr new_te ve expr `thenNF_Tc` \ new_expr -> returnNF_Tc (TyLam new_tyvars new_expr) -zonkExpr (TyApp expr tys) - = zonkExpr expr `thenNF_Tc` \ new_expr -> - mapNF_Tc zonkTcTypeToType tys `thenNF_Tc` \ new_tys -> +zonkExpr te ve (TyApp expr tys) + = zonkExpr te ve expr `thenNF_Tc` \ new_expr -> + mapNF_Tc (zonkTcTypeToType te) tys `thenNF_Tc` \ new_tys -> returnNF_Tc (TyApp new_expr new_tys) -zonkExpr (DictLam dicts expr) - = mapNF_Tc zonkId dicts `thenNF_Tc` \ new_dicts -> - zonkExpr expr `thenNF_Tc` \ new_expr -> +zonkExpr te ve (DictLam dicts expr) + = mapNF_Tc (zonkIdBndr te) dicts `thenNF_Tc` \ new_dicts -> + let + new_ve = extend_ve ve new_dicts + in + zonkExpr te new_ve expr `thenNF_Tc` \ new_expr -> returnNF_Tc (DictLam new_dicts new_expr) -zonkExpr (DictApp expr dicts) - = zonkExpr expr `thenNF_Tc` \ new_expr -> - mapNF_Tc zonkId dicts `thenNF_Tc` \ new_dicts -> +zonkExpr te ve (DictApp expr dicts) + = zonkExpr te ve expr `thenNF_Tc` \ new_expr -> returnNF_Tc (DictApp new_expr new_dicts) + where + new_dicts = map (zonkIdOcc ve) dicts -zonkExpr (ClassDictLam dicts methods expr) - = mapNF_Tc zonkId dicts `thenNF_Tc` \ new_dicts -> - mapNF_Tc zonkId methods `thenNF_Tc` \ new_methods -> - zonkExpr expr `thenNF_Tc` \ new_expr -> +zonkExpr te ve (ClassDictLam dicts methods expr) + = zonkExpr te ve expr `thenNF_Tc` \ new_expr -> returnNF_Tc (ClassDictLam new_dicts new_methods new_expr) + where + new_dicts = map (zonkIdOcc ve) dicts + new_methods = map (zonkIdOcc ve) methods + -zonkExpr (Dictionary dicts methods) - = mapNF_Tc zonkId dicts `thenNF_Tc` \ new_dicts -> - mapNF_Tc zonkId methods `thenNF_Tc` \ new_methods -> - returnNF_Tc (Dictionary new_dicts new_methods) +zonkExpr te ve (Dictionary dicts methods) + = returnNF_Tc (Dictionary new_dicts new_methods) + where + new_dicts = map (zonkIdOcc ve) dicts + new_methods = map (zonkIdOcc ve) methods -zonkExpr (SingleDict name) - = zonkId name `thenNF_Tc` \ new_name -> - returnNF_Tc (SingleDict new_name) +zonkExpr te ve (SingleDict name) + = returnNF_Tc (SingleDict (zonkIdOcc ve name)) -zonkExpr (HsCon con tys vargs) - = mapNF_Tc zonkTcTypeToType tys `thenNF_Tc` \ new_tys -> - mapNF_Tc zonkExpr vargs `thenNF_Tc` \ new_vargs -> +zonkExpr te ve (HsCon con tys vargs) + = mapNF_Tc (zonkTcTypeToType te) tys `thenNF_Tc` \ new_tys -> + mapNF_Tc (zonkExpr te ve) vargs `thenNF_Tc` \ new_vargs -> returnNF_Tc (HsCon con new_tys new_vargs) ------------------------------------------------------------------------- -zonkArithSeq :: TcArithSeqInfo s -> NF_TcM s TypecheckedArithSeqInfo +zonkArithSeq :: TyVarEnv Type -> IdEnv Id + -> TcArithSeqInfo s -> NF_TcM s TypecheckedArithSeqInfo -zonkArithSeq (From e) - = zonkExpr e `thenNF_Tc` \ new_e -> +zonkArithSeq te ve (From e) + = zonkExpr te ve e `thenNF_Tc` \ new_e -> returnNF_Tc (From new_e) -zonkArithSeq (FromThen e1 e2) - = zonkExpr e1 `thenNF_Tc` \ new_e1 -> - zonkExpr e2 `thenNF_Tc` \ new_e2 -> +zonkArithSeq te ve (FromThen e1 e2) + = zonkExpr te ve e1 `thenNF_Tc` \ new_e1 -> + zonkExpr te ve e2 `thenNF_Tc` \ new_e2 -> returnNF_Tc (FromThen new_e1 new_e2) -zonkArithSeq (FromTo e1 e2) - = zonkExpr e1 `thenNF_Tc` \ new_e1 -> - zonkExpr e2 `thenNF_Tc` \ new_e2 -> +zonkArithSeq te ve (FromTo e1 e2) + = zonkExpr te ve e1 `thenNF_Tc` \ new_e1 -> + zonkExpr te ve e2 `thenNF_Tc` \ new_e2 -> returnNF_Tc (FromTo new_e1 new_e2) -zonkArithSeq (FromThenTo e1 e2 e3) - = zonkExpr e1 `thenNF_Tc` \ new_e1 -> - zonkExpr e2 `thenNF_Tc` \ new_e2 -> - zonkExpr e3 `thenNF_Tc` \ new_e3 -> +zonkArithSeq te ve (FromThenTo e1 e2 e3) + = zonkExpr te ve e1 `thenNF_Tc` \ new_e1 -> + zonkExpr te ve e2 `thenNF_Tc` \ new_e2 -> + zonkExpr te ve e3 `thenNF_Tc` \ new_e3 -> returnNF_Tc (FromThenTo new_e1 new_e2 new_e3) ------------------------------------------------------------------------- -zonkQuals :: [TcQual s] -> NF_TcM s [TypecheckedQual] - -zonkQuals quals - = mapNF_Tc zonk_qual quals - where - zonk_qual (GeneratorQual pat expr) - = zonkPat pat `thenNF_Tc` \ new_pat -> - zonkExpr expr `thenNF_Tc` \ new_expr -> - returnNF_Tc (GeneratorQual new_pat new_expr) - - zonk_qual (FilterQual expr) - = zonkExpr expr `thenNF_Tc` \ new_expr -> - returnNF_Tc (FilterQual new_expr) - - zonk_qual (LetQual binds) - = zonkBinds binds `thenNF_Tc` \ new_binds -> - returnNF_Tc (LetQual new_binds) +zonkQuals :: TyVarEnv Type -> IdEnv Id + -> [TcQual s] -> NF_TcM s ([TypecheckedQual], IdEnv Id) + +zonkQuals te ve [] + = returnNF_Tc ([], ve) + +zonkQuals te ve (GeneratorQual pat expr : quals) + = zonkPat te ve pat `thenNF_Tc` \ (new_pat, ids) -> + zonkExpr te ve expr `thenNF_Tc` \ new_expr -> + let + new_ve = extend_ve ve ids + in + zonkQuals te new_ve quals `thenNF_Tc` \ (new_quals, final_ve) -> + returnNF_Tc (GeneratorQual new_pat new_expr : new_quals, final_ve) + +zonkQuals te ve (FilterQual expr : quals) + = zonkExpr te ve expr `thenNF_Tc` \ new_expr -> + zonkQuals te ve quals `thenNF_Tc` \ (new_quals, final_ve) -> + returnNF_Tc (FilterQual new_expr : new_quals, final_ve) + +zonkQuals te ve (LetQual binds : quals) + = zonkBinds te ve binds `thenNF_Tc` \ (new_binds, new_ve) -> + zonkQuals te new_ve quals `thenNF_Tc` \ (new_quals, final_ve) -> + returnNF_Tc (LetQual new_binds : new_quals, final_ve) ------------------------------------------------------------------------- -zonkStmts :: [TcStmt s] -> NF_TcM s [TypecheckedStmt] - -zonkStmts stmts - = mapNF_Tc zonk_stmt stmts - where - zonk_stmt (BindStmt pat expr src_loc) - = zonkPat pat `thenNF_Tc` \ new_pat -> - zonkExpr expr `thenNF_Tc` \ new_expr -> - returnNF_Tc (BindStmt new_pat new_expr src_loc) - - zonk_stmt (ExprStmt expr src_loc) - = zonkExpr expr `thenNF_Tc` \ new_expr -> - returnNF_Tc (ExprStmt new_expr src_loc) - - zonk_stmt (LetStmt binds) - = zonkBinds binds `thenNF_Tc` \ new_binds -> - returnNF_Tc (LetStmt new_binds) +zonkStmts :: TyVarEnv Type -> IdEnv Id + -> [TcStmt s] -> NF_TcM s [TypecheckedStmt] + +zonkStmts te ve [] + = returnNF_Tc [] + +zonkStmts te ve (BindStmt pat expr src_loc : stmts) + = zonkPat te ve pat `thenNF_Tc` \ (new_pat, ids) -> + zonkExpr te ve expr `thenNF_Tc` \ new_expr -> + let + new_ve = extend_ve ve ids + in + zonkStmts te new_ve stmts `thenNF_Tc` \ new_stmts -> + returnNF_Tc (BindStmt new_pat new_expr src_loc : new_stmts) + +zonkStmts te ve (ExprStmt expr src_loc : stmts) + = zonkExpr te ve expr `thenNF_Tc` \ new_expr -> + zonkStmts te ve stmts `thenNF_Tc` \ new_stmts -> + returnNF_Tc (ExprStmt new_expr src_loc : new_stmts) + +zonkStmts te ve (LetStmt binds : stmts) + = zonkBinds te ve binds `thenNF_Tc` \ (new_binds, new_ve) -> + zonkStmts te new_ve stmts `thenNF_Tc` \ new_stmts -> + returnNF_Tc (LetStmt new_binds : new_stmts) ------------------------------------------------------------------------- -zonkRbinds :: TcRecordBinds s -> NF_TcM s TypecheckedRecordBinds +zonkRbinds :: TyVarEnv Type -> IdEnv Id + -> TcRecordBinds s -> NF_TcM s TypecheckedRecordBinds -zonkRbinds rbinds +zonkRbinds te ve rbinds = mapNF_Tc zonk_rbind rbinds where zonk_rbind (field, expr, pun) - = zonkId field `thenNF_Tc` \ new_field -> - zonkExpr expr `thenNF_Tc` \ new_expr -> - returnNF_Tc (new_field, new_expr, pun) + = zonkExpr te ve expr `thenNF_Tc` \ new_expr -> + returnNF_Tc (zonkIdOcc ve field, new_expr, pun) \end{code} %************************************************************************ @@ -517,67 +599,77 @@ zonkRbinds rbinds %************************************************************************ \begin{code} -zonkPat :: TcPat s -> NF_TcM s TypecheckedPat - -zonkPat (WildPat ty) - = zonkTcTypeToType ty `thenNF_Tc` \ new_ty -> - returnNF_Tc (WildPat new_ty) - -zonkPat (VarPat v) - = zonkId v `thenNF_Tc` \ new_v -> - returnNF_Tc (VarPat new_v) - -zonkPat (LazyPat pat) - = zonkPat pat `thenNF_Tc` \ new_pat -> - returnNF_Tc (LazyPat new_pat) - -zonkPat (AsPat n pat) - = zonkId n `thenNF_Tc` \ new_n -> - zonkPat pat `thenNF_Tc` \ new_pat -> - returnNF_Tc (AsPat new_n new_pat) - -zonkPat (ConPat n ty pats) - = zonkTcTypeToType ty `thenNF_Tc` \ new_ty -> - mapNF_Tc zonkPat pats `thenNF_Tc` \ new_pats -> - returnNF_Tc (ConPat n new_ty new_pats) - -zonkPat (ConOpPat pat1 op pat2 ty) - = zonkPat pat1 `thenNF_Tc` \ new_pat1 -> - zonkPat pat2 `thenNF_Tc` \ new_pat2 -> - zonkTcTypeToType ty `thenNF_Tc` \ new_ty -> - returnNF_Tc (ConOpPat new_pat1 op new_pat2 new_ty) - -zonkPat (ListPat ty pats) - = zonkTcTypeToType ty `thenNF_Tc` \ new_ty -> - mapNF_Tc zonkPat pats `thenNF_Tc` \ new_pats -> - returnNF_Tc (ListPat new_ty new_pats) - -zonkPat (TuplePat pats) - = mapNF_Tc zonkPat pats `thenNF_Tc` \ new_pats -> - returnNF_Tc (TuplePat new_pats) - -zonkPat (RecPat n ty rpats) - = zonkTcTypeToType ty `thenNF_Tc` \ new_ty -> - mapNF_Tc zonk_rpat rpats `thenNF_Tc` \ new_rpats -> - returnNF_Tc (RecPat n new_ty new_rpats) +zonkPat :: TyVarEnv Type -> IdEnv Id + -> TcPat s -> NF_TcM s (TypecheckedPat, [Id]) + +zonkPat te ve (WildPat ty) + = zonkTcTypeToType te ty `thenNF_Tc` \ new_ty -> + returnNF_Tc (WildPat new_ty, []) + +zonkPat te ve (VarPat v) + = zonkIdBndr te v `thenNF_Tc` \ new_v -> + returnNF_Tc (VarPat new_v, [new_v]) + +zonkPat te ve (LazyPat pat) + = zonkPat te ve pat `thenNF_Tc` \ (new_pat, ids) -> + returnNF_Tc (LazyPat new_pat, ids) + +zonkPat te ve (AsPat n pat) + = zonkIdBndr te n `thenNF_Tc` \ new_n -> + zonkPat te ve pat `thenNF_Tc` \ (new_pat, ids) -> + returnNF_Tc (AsPat new_n new_pat, new_n:ids) + +zonkPat te ve (ConPat n ty pats) + = zonkTcTypeToType te ty `thenNF_Tc` \ new_ty -> + zonkPats te ve pats `thenNF_Tc` \ (new_pats, ids) -> + returnNF_Tc (ConPat n new_ty new_pats, ids) + +zonkPat te ve (ConOpPat pat1 op pat2 ty) + = zonkPat te ve pat1 `thenNF_Tc` \ (new_pat1, ids1) -> + zonkPat te ve pat2 `thenNF_Tc` \ (new_pat2, ids2) -> + zonkTcTypeToType te ty `thenNF_Tc` \ new_ty -> + returnNF_Tc (ConOpPat new_pat1 op new_pat2 new_ty, ids1 ++ ids2) + +zonkPat te ve (ListPat ty pats) + = zonkTcTypeToType te ty `thenNF_Tc` \ new_ty -> + zonkPats te ve pats `thenNF_Tc` \ (new_pats, ids) -> + returnNF_Tc (ListPat new_ty new_pats, ids) + +zonkPat te ve (TuplePat pats) + = zonkPats te ve pats `thenNF_Tc` \ (new_pats, ids) -> + returnNF_Tc (TuplePat new_pats, ids) + +zonkPat te ve (RecPat n ty rpats) + = zonkTcTypeToType te ty `thenNF_Tc` \ new_ty -> + mapAndUnzipNF_Tc zonk_rpat rpats `thenNF_Tc` \ (new_rpats, ids_s) -> + returnNF_Tc (RecPat n new_ty new_rpats, concat ids_s) where zonk_rpat (f, pat, pun) - = zonkPat pat `thenNF_Tc` \ new_pat -> - returnNF_Tc (f, new_pat, pun) - -zonkPat (LitPat lit ty) - = zonkTcTypeToType ty `thenNF_Tc` \ new_ty -> - returnNF_Tc (LitPat lit new_ty) - -zonkPat (NPat lit ty expr) - = zonkTcTypeToType ty `thenNF_Tc` \ new_ty -> - zonkExpr expr `thenNF_Tc` \ new_expr -> - returnNF_Tc (NPat lit new_ty new_expr) - -zonkPat (DictPat ds ms) - = mapNF_Tc zonkId ds `thenNF_Tc` \ new_ds -> - mapNF_Tc zonkId ms `thenNF_Tc` \ new_ms -> - returnNF_Tc (DictPat new_ds new_ms) + = zonkPat te ve pat `thenNF_Tc` \ (new_pat, ids) -> + returnNF_Tc ((f, new_pat, pun), ids) + +zonkPat te ve (LitPat lit ty) + = zonkTcTypeToType te ty `thenNF_Tc` \ new_ty -> + returnNF_Tc (LitPat lit new_ty, []) + +zonkPat te ve (NPat lit ty expr) + = zonkTcTypeToType te ty `thenNF_Tc` \ new_ty -> + zonkExpr te ve expr `thenNF_Tc` \ new_expr -> + returnNF_Tc (NPat lit new_ty new_expr, []) + +zonkPat te ve (DictPat ds ms) + = mapNF_Tc (zonkIdBndr te) ds `thenNF_Tc` \ new_ds -> + mapNF_Tc (zonkIdBndr te) ms `thenNF_Tc` \ new_ms -> + returnNF_Tc (DictPat new_ds new_ms, new_ds ++ new_ms) + + +zonkPats te ve [] + = returnNF_Tc ([], []) +zonkPats te ve (pat:pats) + = zonkPat te ve pat `thenNF_Tc` \ (pat', ids1) -> + zonkPats te ve pats `thenNF_Tc` \ (pats', ids2) -> + returnNF_Tc (pat':pats', ids1 ++ ids2) + \end{code} diff --git a/ghc/compiler/typecheck/TcInstDcls.lhs b/ghc/compiler/typecheck/TcInstDcls.lhs index 238e3fd..0f1a61a 100644 --- a/ghc/compiler/typecheck/TcInstDcls.lhs +++ b/ghc/compiler/typecheck/TcInstDcls.lhs @@ -81,7 +81,7 @@ import Type ( GenType(..), ThetaType(..), mkTyVarTys, import TyVar ( GenTyVar, mkTyVarSet ) import TysWiredIn ( stringTy ) import Unique ( Unique ) -import Util ( panic ) +import Util ( zipEqual, panic ) \end{code} Typechecking instance declarations is done in two passes. The first @@ -244,7 +244,7 @@ tcInstDecl1 mod_name else -- Make the dfun id and constant-method ids - mkInstanceRelatedIds from_here inst_mod pragmas + mkInstanceRelatedIds from_here src_loc inst_mod pragmas clas inst_tyvars inst_tau inst_theta uprags `thenTc` \ (dfun_id, dfun_theta, const_meth_ids) -> @@ -366,7 +366,7 @@ tcInstDecl2 (InstInfo clas inst_tyvars inst_ty tcInstTheta tenv dfun_theta `thenNF_Tc` \ dfun_theta' -> tcInstTheta tenv inst_decl_theta `thenNF_Tc` \ inst_decl_theta' -> let - sc_theta' = super_classes `zip` (repeat inst_ty') + sc_theta' = super_classes `zip` repeat inst_ty' origin = InstanceDeclOrigin mk_method sel_id = newMethodId sel_id inst_ty' origin locn in @@ -435,8 +435,8 @@ tcInstDecl2 (InstInfo clas inst_tyvars inst_ty inst_tyvars' dfun_arg_dicts_ids ((this_dict_id, RealId dfun_id) - : (meth_ids `zip` (map RealId const_meth_ids))) - -- const_meth_ids will often be empty + : (meth_ids `zip` map RealId const_meth_ids)) + -- NB: const_meth_ids will often be empty super_binds (RecBind dict_and_method_binds) @@ -666,11 +666,18 @@ processInstBinds1 clas inst_tyvars avail_insts method_ids mbind let tag = classOpTagByString clas occ method_id = method_ids !! (tag-1) + in - method_ty = tcIdType method_id + -- The "method" might be a RealId, when processInstBinds is used by + -- TcClassDcls:buildDefaultMethodBinds to make default-method bindings + (case method_id of + TcId id -> returnNF_Tc (idType id) + RealId id -> tcInstType [] (idType id) + ) `thenNF_Tc` \ method_ty -> + let (method_tyvars, method_theta, method_tau) = splitSigmaTy method_ty in - newDicts origin method_theta `thenNF_Tc` \ (method_dicts,method_dict_ids) -> + newDicts origin method_theta `thenNF_Tc` \ (method_dicts,method_dict_ids) -> case (method_tyvars, method_dict_ids) of @@ -813,16 +820,19 @@ tcSpecInstSig e ce tce inst_infos inst_mapper (SpecInstSig class_name ty src_loc mk_spec_origin clas ty = InstanceSpecOrigin inst_mapper clas ty src_loc + -- I'm VERY SUSPICIOUS ABOUT THIS + -- the inst-mapper is in a knot at this point so it's no good + -- looking at it in tcSimplify... in tcSimplifyThetas mk_spec_origin subst_tv_theta `thenTc` \ simpl_tv_theta -> let simpl_theta = [ (clas, tv_to_tmpl tv) | (clas, tv) <- simpl_tv_theta ] - tv_tmpl_map = inst_tv_tys `zipEqual` inst_tmpl_tys + tv_tmpl_map = zipEqual "tcSpecInstSig" inst_tv_tys inst_tmpl_tys tv_to_tmpl tv = assoc "tcSpecInstSig" tv_tmpl_map tv in - mkInstanceRelatedIds e True{-from here-} mod NoInstancePragmas src_loc + mkInstanceRelatedIds e True{-from here-} src_loc mod NoInstancePragmas clas inst_tmpls inst_ty simpl_theta uprag `thenTc` \ (dfun_id, dfun_theta, const_meth_ids) -> diff --git a/ghc/compiler/typecheck/TcInstUtil.lhs b/ghc/compiler/typecheck/TcInstUtil.lhs index c8180ab..b41b4ea 100644 --- a/ghc/compiler/typecheck/TcInstUtil.lhs +++ b/ghc/compiler/typecheck/TcInstUtil.lhs @@ -41,7 +41,6 @@ import TyVar ( GenTyVar ) import Unique ( Unique ) import Util ( equivClasses, zipWithEqual, panic ) - import IdInfo ( noIdInfo ) --import TcPragmas ( tcDictFunPragmas, tcGenPragmas ) \end{code} @@ -77,6 +76,7 @@ data InstInfo \begin{code} mkInstanceRelatedIds :: Bool + -> SrcLoc -> Maybe Module -> RenamedInstancePragmas -> Class @@ -86,7 +86,7 @@ mkInstanceRelatedIds :: Bool -> [RenamedSig] -> TcM s (Id, ThetaType, [Id]) -mkInstanceRelatedIds from_here inst_mod inst_pragmas +mkInstanceRelatedIds from_here src_loc inst_mod inst_pragmas clas inst_tyvars inst_ty inst_decl_theta uprags = -- MAKE THE DFUN ID let @@ -114,7 +114,7 @@ mkInstanceRelatedIds from_here inst_mod inst_pragmas -} let dfun_id_info = noIdInfo in -- For now - returnTc (mkDictFunId dfun_uniq clas inst_ty dfun_ty from_here inst_mod dfun_id_info) + returnTc (mkDictFunId dfun_uniq clas inst_ty dfun_ty from_here src_loc inst_mod dfun_id_info) ) `thenTc` \ dfun_id -> -- MAKE THE CONSTANT-METHOD IDS @@ -131,7 +131,7 @@ mkInstanceRelatedIds from_here inst_mod inst_pragmas (class_tyvar, super_classes, _, class_ops, _, _) = classBigSig clas tenv = [(class_tyvar, inst_ty)] - super_class_theta = super_classes `zip` (repeat inst_ty) + super_class_theta = super_classes `zip` repeat inst_ty mk_const_meth_id op = tcGetUnique `thenNF_Tc` \ uniq -> @@ -147,7 +147,7 @@ mkInstanceRelatedIds from_here inst_mod inst_pragmas let id_info = noIdInfo -- For now in returnTc (mkConstMethodId uniq clas op inst_ty meth_ty - from_here inst_mod id_info) + from_here src_loc inst_mod id_info) ) where op_ty = classOpLocalType op @@ -235,8 +235,8 @@ addClassInstance -- Add the instance to the class's instance environment case insertMEnv matchTy class_inst_env inst_ty dfun_id of { - Failed (ty', dfun_id') -> failTc (dupInstErr clas (inst_ty, src_loc) - (ty', getSrcLoc dfun_id')); + Failed (ty', dfun_id') -> dupInstFailure clas (inst_ty, src_loc) + (ty', getSrcLoc dfun_id'); Succeeded class_inst_env' -> -- If there are any constant methods, then add them to @@ -265,7 +265,7 @@ addClassInstance -- a dictionary to be chucked away. op_spec_envs' | null const_meth_ids = op_spec_envs - | otherwise = zipWithEqual add_const_meth op_spec_envs const_meth_ids + | otherwise = zipWithEqual "add_const_meth" add_const_meth op_spec_envs const_meth_ids add_const_meth (op,spec_env) meth_id = (op, case addOneToSpecEnv spec_env (inst_ty : local_tyvar_tys) rhs of @@ -283,13 +283,13 @@ addClassInstance \end{code} \begin{code} -dupInstErr clas info1@(ty1, locn1) info2@(ty2, locn2) sty +dupInstFailure clas info1@(ty1, locn1) info2@(ty2, locn2) -- Overlapping/duplicate instances for given class; msg could be more glamourous - = ppHang (ppBesides [ppStr "Duplicate/overlapping instances: class `", ppr sty clas, ppStr "'"]) - 4 (showOverlap sty info1 info2) - -showOverlap sty (ty1,loc1) (ty2,loc2) - = ppSep [ppBesides [ppStr "type `", ppr sty ty1, ppStr "'"], - ppBesides [ppStr "at ", ppr sty loc1], - ppBesides [ppStr "and ", ppr sty loc2]] + = tcAddErrCtxt ctxt $ + failTc (\sty -> ppStr "Duplicate or overlapping instance declarations") + where + ctxt sty = ppHang (ppSep [ppBesides[ppStr "Class `", ppr sty clas, ppStr "'"], + ppBesides[ppStr "type `", ppr sty ty1, ppStr "'"]]) + 4 (ppSep [ppBesides [ppStr "at ", ppr sty locn1], + ppBesides [ppStr "and ", ppr sty locn2]]) \end{code} diff --git a/ghc/compiler/typecheck/TcKind.lhs b/ghc/compiler/typecheck/TcKind.lhs index 3026867..5e7becf 100644 --- a/ghc/compiler/typecheck/TcKind.lhs +++ b/ghc/compiler/typecheck/TcKind.lhs @@ -14,12 +14,14 @@ module TcKind ( tcDefaultKind -- TcKind s -> NF_TcM s Kind ) where +import Ubiq{-uitous-} + import Kind import TcMonad hiding ( rnMtoTcM ) -import Ubiq import Unique ( Unique, pprUnique10 ) import Pretty +import Util ( nOfThem ) \end{code} @@ -39,7 +41,7 @@ newKindVar = tcGetUnique `thenNF_Tc` \ uniq -> returnNF_Tc (TcVarKind uniq box) newKindVars :: Int -> NF_TcM s [TcKind s] -newKindVars n = mapNF_Tc (\_->newKindVar) (take n (repeat ())) +newKindVars n = mapNF_Tc (\ _ -> newKindVar) (nOfThem n ()) \end{code} diff --git a/ghc/compiler/typecheck/TcModule.lhs b/ghc/compiler/typecheck/TcModule.lhs index f279531..9f3506b 100644 --- a/ghc/compiler/typecheck/TcModule.lhs +++ b/ghc/compiler/typecheck/TcModule.lhs @@ -25,7 +25,7 @@ import HsSyn ( HsModule(..), HsBinds(..), Bind, HsExpr, ) import RnHsSyn ( RenamedHsModule(..), RenamedFixityDecl(..) ) import TcHsSyn ( TypecheckedHsBinds(..), TypecheckedHsExpr(..), - TcIdOcc(..), zonkBinds, zonkInst, zonkId ) + TcIdOcc(..), zonkBinds, zonkDictBinds ) import TcMonad hiding ( rnMtoTcM ) import Inst ( Inst, plusLIE ) @@ -40,11 +40,12 @@ import TcInstDcls ( tcInstDecls1, tcInstDecls2 ) import TcInstUtil ( buildInstanceEnvs, InstInfo ) import TcSimplify ( tcSimplifyTop ) import TcTyClsDecls ( tcTyAndClassDecls1 ) +import TcTyDecls ( mkDataBinds ) import Bag ( listToBag ) -import Class ( GenClass ) +import Class ( GenClass, classSelIds ) import ErrUtils ( Warning(..), Error(..) ) -import Id ( GenId, isDataCon, isMethodSelId, idType ) +import Id ( GenId, isDataCon, isMethodSelId, idType, IdEnv(..), nullIdEnv ) import Maybes ( catMaybes ) import Name ( isExported, isLocallyDefined ) import PrelInfo ( unitTy, mkPrimIoTy ) @@ -52,6 +53,7 @@ import Pretty import RnUtils ( RnEnv(..) ) import TyCon ( TyCon ) import Type ( mkSynTy ) +import TyVar ( TyVarEnv(..), nullTyVarEnv ) import Unify ( unifyTauTy ) import UniqFM ( lookupUFM_Directly, lookupWithDefaultUFM_Directly, filterUFM, eltsUFM ) @@ -136,12 +138,12 @@ tcModule rn_env -- The knot for instance information. This isn't used at all -- till we type-check value declarations - fixTc ( \ ~(rec_inst_mapper, _, _, _, _, _) -> + fixTc ( \ ~(rec_inst_mapper, _, _, _, _) -> -- Type-check the type and class decls --trace "tcTyAndClassDecls:" $ tcTyAndClassDecls1 rec_inst_mapper ty_decls_bag cls_decls_bag - `thenTc` \ (env, record_binds) -> + `thenTc` \ env -> -- Typecheck the instance decls, includes deriving tcSetEnv env ( @@ -152,15 +154,30 @@ tcModule rn_env buildInstanceEnvs inst_info `thenTc` \ inst_mapper -> - returnTc (inst_mapper, env, record_binds, inst_info, deriv_binds, ddump_deriv) + returnTc (inst_mapper, env, inst_info, deriv_binds, ddump_deriv) - ) `thenTc` \ (_, env, record_binds, inst_info, deriv_binds, ddump_deriv) -> + ) `thenTc` \ (_, env, inst_info, deriv_binds, ddump_deriv) -> tcSetEnv env ( -- Default declarations tcDefaults default_decls `thenTc` \ defaulting_tys -> tcSetDefaultTys defaulting_tys ( -- for the iface sigs... + -- Create any necessary record selector Ids and their bindings + -- "Necessary" includes data and newtype declarations + let + tycons = getEnv_TyCons env + classes = getEnv_Classes env + in + mkDataBinds tycons `thenTc` \ (data_ids, data_binds) -> + + -- Extend the global value environment with + -- a) constructors + -- b) record selectors + -- c) class op selectors + tcExtendGlobalValEnv data_ids $ + tcExtendGlobalValEnv (concat (map classSelIds classes)) $ + -- Interface type signatures -- We tie a knot so that the Ids read out of interfaces are in scope -- when we read their pragmas. @@ -169,9 +186,9 @@ tcModule rn_env -- we silently discard the pragma tcInterfaceSigs sigs `thenTc` \ sig_ids -> - returnTc (env, inst_info, record_binds, deriv_binds, ddump_deriv, defaulting_tys, sig_ids) + returnTc (env, inst_info, data_binds, deriv_binds, ddump_deriv, defaulting_tys, sig_ids) - )))) `thenTc` \ (env, inst_info, record_binds, deriv_binds, ddump_deriv, defaulting_tys, _) -> + )))) `thenTc` \ (env, inst_info, data_binds, deriv_binds, ddump_deriv, defaulting_tys, _) -> tcSetEnv env ( -- to the end... tcSetDefaultTys defaulting_tys ( -- ditto @@ -202,6 +219,26 @@ tcModule rn_env -- type. (Usually, ambiguous type variables are resolved -- during the generalisation step.) tcSimplifyTop lie_alldecls `thenTc` \ const_insts -> + + -- Backsubstitution. Monomorphic top-level decls may have + -- been instantiated by subsequent decls, and the final + -- simplification step may have instantiated some + -- ambiguous types. So, sadly, we need to back-substitute + -- over the whole bunch of bindings. + -- + -- More horrible still, we have to do it in a careful order, so that + -- all the TcIds are in scope when we come across them. + -- + -- These bindings ought really to be bundled together in a huge + -- recursive group, but HsSyn doesn't have recursion among Binds, only + -- among MonoBinds. Sigh again. + zonkDictBinds nullTyVarEnv nullIdEnv const_insts `thenNF_Tc` \ (const_insts', ve1) -> + zonkBinds nullTyVarEnv ve1 val_binds `thenNF_Tc` \ (val_binds', ve2) -> + + zonkBinds nullTyVarEnv ve2 data_binds `thenNF_Tc` \ (data_binds', _) -> + zonkBinds nullTyVarEnv ve2 inst_binds `thenNF_Tc` \ (inst_binds', _) -> + zonkBinds nullTyVarEnv ve2 cls_binds `thenNF_Tc` \ (cls_binds', _) -> + let localids = getEnv_LocalIds final_env tycons = getEnv_TyCons final_env @@ -209,25 +246,12 @@ tcModule rn_env local_tycons = filter isLocallyDefined tycons local_classes = filter isLocallyDefined classes - - exported_ids = [v | v <- localids, - isExported v && not (isDataCon v) && not (isMethodSelId v)] - in - -- Backsubstitution. Monomorphic top-level decls may have - -- been instantiated by subsequent decls, and the final - -- simplification step may have instantiated some - -- ambiguous types. So, sadly, we need to back-substitute - -- over the whole bunch of bindings. - zonkBinds record_binds `thenNF_Tc` \ record_binds' -> - zonkBinds val_binds `thenNF_Tc` \ val_binds' -> - zonkBinds inst_binds `thenNF_Tc` \ inst_binds' -> - zonkBinds cls_binds `thenNF_Tc` \ cls_binds' -> - mapNF_Tc zonkInst const_insts `thenNF_Tc` \ const_insts' -> - mapNF_Tc (zonkId.TcId) exported_ids `thenNF_Tc` \ exported_ids' -> + exported_ids' = filter isExported (eltsUFM ve2) + in -- FINISHED AT LAST returnTc ( - (record_binds', cls_binds', inst_binds', val_binds', const_insts'), + (data_binds', cls_binds', inst_binds', val_binds', const_insts'), -- the next collection is just for mkInterface (exported_ids', tycons, classes, inst_info), diff --git a/ghc/compiler/typecheck/TcMonad.lhs b/ghc/compiler/typecheck/TcMonad.lhs index 9be9dde..876564d 100644 --- a/ghc/compiler/typecheck/TcMonad.lhs +++ b/ghc/compiler/typecheck/TcMonad.lhs @@ -8,7 +8,7 @@ module TcMonad( foldrTc, foldlTc, mapAndUnzipTc, mapAndUnzip3Tc, mapBagTc, fixTc, tryTc, - returnNF_Tc, thenNF_Tc, thenNF_Tc_, mapNF_Tc, + returnNF_Tc, thenNF_Tc, thenNF_Tc_, mapNF_Tc, fixNF_Tc, listNF_Tc, mapAndUnzipNF_Tc, mapBagNF_Tc, checkTc, checkTcM, checkMaybeTc, checkMaybeTcM, @@ -127,6 +127,9 @@ thenNF_Tc_ m k down env returnNF_Tc :: a -> NF_TcM s a returnNF_Tc v down env = returnSST v +fixNF_Tc :: (a -> NF_TcM s a) -> NF_TcM s a +fixNF_Tc m env down = fixSST (\ loop -> m loop env down) + mapNF_Tc :: (a -> NF_TcM s b) -> [a] -> NF_TcM s [b] mapNF_Tc f [] = returnNF_Tc [] mapNF_Tc f (x:xs) = f x `thenNF_Tc` \ r -> diff --git a/ghc/compiler/typecheck/TcPragmas.lhs b/ghc/compiler/typecheck/TcPragmas.lhs index 40df4a8..8e28da6 100644 --- a/ghc/compiler/typecheck/TcPragmas.lhs +++ b/ghc/compiler/typecheck/TcPragmas.lhs @@ -233,7 +233,7 @@ do_strictness e (Just wrapper_ty) rec_final_id = -- Strictness info suggests a worker. Things could still -- go wrong if there's an abstract type involved, mind you. let - (tv_tmpls, arg_tys, ret_ty) = splitTypeWithDictsAsArgs wrapper_ty + (tv_tmpls, arg_tys, ret_ty) = splitFunTyExpandingDicts wrapper_ty n_wrapper_args = length wrap_arg_info -- Don't have more args than this, else you risk -- losing laziness!! @@ -251,7 +251,7 @@ do_strictness e (Just wrapper_ty) rec_final_id inst_ret_ty = glueTyArgs dropped_inst_arg_tys (instantiateTy inst_env ret_ty) - args = zipWithEqual mk_arg arg_uniqs undropped_inst_arg_tys + args = zipWithEqual "do_strictness" mk_arg arg_uniqs undropped_inst_arg_tys mk_arg uniq ty = mkSysLocal SLIT("wrap") uniq ty mkUnknownSrcLoc -- ASSERT: length args = n_wrapper_args in @@ -483,7 +483,7 @@ tc_unfolding e (ImpUnfolding guidance uf_core) in mapB_Tc (tc_uf_core new_lve tve) rhss `thenB_Tc` \ new_rhss -> tc_uf_core new_lve tve body `thenB_Tc` \ new_body -> - returnB_Tc (Let (Rec (new_binders `zip` new_rhss)) new_body) + returnB_Tc (Let (Rec (zipEqual "tc_uf_core" new_binders new_rhss)) new_body) tc_uf_core lve tve (UfSCC uf_cc body) = tc_uf_cc uf_cc `thenB_Tc` \ new_cc -> diff --git a/ghc/compiler/typecheck/TcSimplify.lhs b/ghc/compiler/typecheck/TcSimplify.lhs index bcb90dd..fcde43d 100644 --- a/ghc/compiler/typecheck/TcSimplify.lhs +++ b/ghc/compiler/typecheck/TcSimplify.lhs @@ -20,7 +20,8 @@ import HsSyn ( MonoBinds(..), HsExpr(..), InPat, OutPat, HsLit, import TcHsSyn ( TcIdOcc(..), TcIdBndr(..), TcExpr(..), TcMonoBinds(..) ) import TcMonad hiding ( rnMtoTcM ) -import Inst ( lookupInst, tyVarsOfInst, isTyVarDict, isDict, matchesInst, +import Inst ( lookupInst, lookupSimpleInst, + tyVarsOfInst, isTyVarDict, isDict, matchesInst, instToId, instBindingRequired, instCanBeGeneralised, newDictsAtLoc, Inst(..), LIE(..), zonkLIE, emptyLIE, plusLIE, unitLIE, consLIE, InstOrigin(..), OverloadedLit ) @@ -30,8 +31,9 @@ import Unify ( unifyTauTy ) import Bag ( Bag, unitBag, listToBag, foldBag, filterBag, emptyBag, bagToList, snocBag, consBag, unionBags, isEmptyBag ) -import Class ( isNumericClass, isStandardClass, isCcallishClass, - isSuperClassOf, classSuperDictSelId +import Class ( GenClass, Class(..), ClassInstEnv(..), + isNumericClass, isStandardClass, isCcallishClass, + isSuperClassOf, classSuperDictSelId, classInstEnv ) import Id ( GenId ) import Maybes ( expectJust, firstJust, catMaybes, seqMaybe, maybeToBool, Maybe(..) ) @@ -41,7 +43,8 @@ import PprType ( GenType, GenTyVar, GenClass{-instance Outputable;ToDo:rm-} ) import Pretty import SrcLoc ( mkUnknownSrcLoc ) import Util -import Type ( GenType, Type(..), TauType(..), mkTyVarTy, getTyVar, eqSimpleTy ) +import Type ( GenType, Type(..), TauType(..), mkTyVarTy, getTyVar, eqSimpleTy, + getTyVar_maybe ) import TysWiredIn ( intTy ) import TyVar ( GenTyVar, GenTyVarSet(..), elementOfTyVarSet, emptyTyVarSet, unionTyVarSets, @@ -228,72 +231,10 @@ mechansim with the extra flag to say ``beat out constant insts''. \begin{code} tcSimplifyTop :: LIE s -> TcM s [(TcIdOcc s, TcExpr s)] tcSimplifyTop dicts - = tcGetGlobalTyVars `thenNF_Tc` \ global_tvs -> - tcSimpl True emptyTyVarSet emptyTyVarSet emptyBag dicts `thenTc` \ (_, binds, _) -> + = tcSimpl True emptyTyVarSet emptyTyVarSet emptyBag dicts `thenTc` \ (_, binds, _) -> returnTc binds \end{code} -@tcSimplifyThetas@ simplifies class-type constraints formed by -@deriving@ declarations and when specialising instances. We are -only interested in the simplified bunch of class/type constraints. - -\begin{code} -tcSimplifyThetas :: (Class -> TauType -> InstOrigin s) -- Creates an origin for the dummy dicts - -> [(Class, TauType)] -- Simplify this - -> TcM s [(Class, TauType)] -- Result - -tcSimplifyThetas = panic "tcSimplifyThetas" - -{- LATER -tcSimplifyThetas mk_inst_origin theta - = let - dicts = listToBag (map mk_dummy_dict theta) - in - -- Do the business (this is just the heart of "tcSimpl") - elimTyCons True (\tv -> False) emptyLIE dicts `thenTc` \ (_, _, dicts2) -> - - -- Deal with superclass relationships - elimSCs [] dicts2 `thenNF_Tc` \ (_, dicts3) -> - - returnTc (map unmk_dummy_dict (bagToList dicts3)) - where - mk_dummy_dict (clas, ty) = Dict uniq clas ty (mk_inst_origin clas ty) mkUnknownSrcLoc - uniq = panic "tcSimplifyThetas:uniq" - - unmk_dummy_dict (Dict _ clas ty _ _) = (clas, ty) --} -\end{code} - -@tcSimplifyCheckThetas@ just checks class-type constraints, essentially; -used with \tr{default} declarations. We are only interested in -whether it worked or not. - -\begin{code} -tcSimplifyCheckThetas :: InstOrigin s -- context; for error msg - -> [(Class, TauType)] -- Simplify this - -> TcM s () - -tcSimplifyCheckThetas x y = _trace "tcSimplifyCheckThetas: does nothing" $ - returnTc () - -{- LATER -tcSimplifyCheckThetas origin theta - = let - dicts = map mk_dummy_dict theta - in - -- Do the business (this is just the heart of "tcSimpl") - elimTyCons True (\tv -> False) emptyLIE dicts `thenTc` \ _ -> - - returnTc () - where - mk_dummy_dict (clas, ty) - = Dict uniq clas ty origin mkUnknownSrcLoc - - uniq = panic "tcSimplifyCheckThetas:uniq" --} -\end{code} - - %************************************************************************ %* * \subsection[elimTyCons]{@elimTyCons@} @@ -437,7 +378,7 @@ elimTyCons squash_consts is_free_tv givens wanteds %************************************************************************ %* * \subsection[elimSCs]{@elimSCs@} -%* * +%* 2 * %************************************************************************ \begin{code} @@ -534,13 +475,90 @@ sortSC dicts = sortLt lt (bagToList dicts) = if ty1 `eqSimpleTy` ty2 then maybeToBool (c2 `isSuperClassOf` c1) else - -- order is immaterial, I think... + -- Order is immaterial, I think... False \end{code} %************************************************************************ %* * +\subsection[simple]{@Simple@ versions} +%* * +%************************************************************************ + +Much simpler versions when there are no bindings to make! + +@tcSimplifyThetas@ simplifies class-type constraints formed by +@deriving@ declarations and when specialising instances. We are +only interested in the simplified bunch of class/type constraints. + +\begin{code} +tcSimplifyThetas :: (Class -> ClassInstEnv) -- How to find the ClassInstEnv + -> [(Class, TauType)] -- Given + -> [(Class, TauType)] -- Wanted + -> TcM s [(Class, TauType)] + + +tcSimplifyThetas inst_mapper given wanted + = elimTyConsSimple inst_mapper wanted `thenTc` \ wanted1 -> + returnTc (elimSCsSimple given wanted1) +\end{code} + +@tcSimplifyCheckThetas@ just checks class-type constraints, essentially; +used with \tr{default} declarations. We are only interested in +whether it worked or not. + +\begin{code} +tcSimplifyCheckThetas :: [(Class, TauType)] -- Simplify this to nothing at all + -> TcM s () + +tcSimplifyCheckThetas theta + = elimTyConsSimple classInstEnv theta `thenTc` \ theta1 -> + ASSERT( null theta1 ) + returnTc () +\end{code} + + +\begin{code} +elimTyConsSimple :: (Class -> ClassInstEnv) + -> [(Class,Type)] + -> TcM s [(Class,Type)] +elimTyConsSimple inst_mapper theta + = elim theta + where + elim [] = returnTc [] + elim ((clas,ty):rest) = elim_one clas ty `thenTc` \ r1 -> + elim rest `thenTc` \ r2 -> + returnTc (r1++r2) + + elim_one clas ty + = case getTyVar_maybe ty of + + Just tv -> returnTc [(clas,ty)] + + otherwise -> recoverTc (returnTc []) $ + lookupSimpleInst (inst_mapper clas) clas ty `thenTc` \ theta -> + elim theta + +elimSCsSimple :: [(Class,Type)] -- Given + -> [(Class,Type)] -- Wanted + -> [(Class,Type)] -- Subset of wanted; no dups, no subclass relnships + +elimSCsSimple givens [] = [] +elimSCsSimple givens (c_t@(clas,ty) : rest) + | any (`subsumes` c_t) givens || + any (`subsumes` c_t) rest -- (clas,ty) is old hat + = elimSCsSimple givens rest + | otherwise -- (clas,ty) is new + = c_t : elimSCsSimple (c_t : givens) rest + where + rest' = elimSCsSimple rest + (c1,t1) `subsumes` (c2,t2) = t1 `eqSimpleTy` t2 && + maybeToBool (c2 `isSuperClassOf` c1) +\end{code} + +%************************************************************************ +%* * \subsection[binds-for-local-funs]{@bindInstsOfLocalFuns@} %* * %************************************************************************ @@ -676,7 +694,7 @@ disambigOne dict_infos try_default (default_ty : default_tys) = tryTc (try_default default_tys) $ -- If default_ty fails, we try -- default_tys instead - tcSimplifyCheckThetas DefaultDeclOrigin thetas `thenTc` \ _ -> + tcSimplifyCheckThetas thetas `thenTc` \ _ -> returnTc default_ty where thetas = classes `zip` repeat default_ty diff --git a/ghc/compiler/typecheck/TcTyClsDecls.lhs b/ghc/compiler/typecheck/TcTyClsDecls.lhs index fce676f..495c0a5 100644 --- a/ghc/compiler/typecheck/TcTyClsDecls.lhs +++ b/ghc/compiler/typecheck/TcTyClsDecls.lhs @@ -52,7 +52,7 @@ data Decl = TyD RenamedTyDecl | ClD RenamedClassDecl tcTyAndClassDecls1 :: InstanceMapper -> Bag RenamedTyDecl -> Bag RenamedClassDecl - -> TcM s (TcEnv s, TcHsBinds s) + -> TcM s (TcEnv s) tcTyAndClassDecls1 inst_mapper rnty_decls rncls_decls = sortByDependency syn_decls cls_decls decls `thenTc` \ groups -> @@ -67,33 +67,30 @@ tcTyAndClassDecls1 inst_mapper rnty_decls rncls_decls is_syn_decl _ = False tcGroups inst_mapper [] - = tcGetEnv `thenNF_Tc` \ env -> - returnTc (env, EmptyBinds) + = tcGetEnv `thenNF_Tc` \ env -> + returnTc env tcGroups inst_mapper (group:groups) - = tcGroup inst_mapper group `thenTc` \ (new_env, binds1) -> + = tcGroup inst_mapper group `thenTc` \ new_env -> -- Extend the environment using the new tycons and classes tcSetEnv new_env $ -- Do the remaining groups - tcGroups inst_mapper groups `thenTc` \ (final_env, binds2) -> - - returnTc (final_env, binds1 `ThenBinds` binds2) + tcGroups inst_mapper groups \end{code} Dealing with a group ~~~~~~~~~~~~~~~~~~~~ \begin{code} -tcGroup :: InstanceMapper -> Bag Decl -> TcM s (TcEnv s, TcHsBinds s) +tcGroup :: InstanceMapper -> Bag Decl -> TcM s (TcEnv s) tcGroup inst_mapper decls - = --pprTrace "tcGroup: " (ppCat (map (fst.fmt_decl) (bagToList decls))) $ + = -- pprTrace "tcGroup: " (ppCat (map (fst.fmt_decl) (bagToList decls))) $ -- TIE THE KNOT fixTc ( \ ~(tycons,classes,_) -> -- EXTEND TYPE AND CLASS ENVIRONMENTS - -- including their data constructors and class operations -- NB: it's important that the tycons and classes come back in just -- the same order from this fix as from get_binders, so that these -- extend-env things work properly. A bit UGH-ish. @@ -117,24 +114,9 @@ tcGroup inst_mapper decls tcGetEnv `thenNF_Tc` \ final_env -> returnTc (tycons, classes, final_env) - ) `thenTc` \ (tycons, classes, final_env) -> - + ) `thenTc` \ (_, _, final_env) -> - -- Create any necessary record selector Ids and their bindings - -- "Necessary" includes data and newtype declarations - mapAndUnzipTc mkDataBinds (filter (not.isSynTyCon) tycons) `thenTc` \ (data_ids_s, binds) -> - - -- Extend the global value environment with - -- a) constructors - -- b) record selectors - -- c) class op selectors - - tcSetEnv final_env $ - tcExtendGlobalValEnv (concat data_ids_s) $ - tcExtendGlobalValEnv (concat (map classSelIds classes)) $ - tcGetEnv `thenNF_Tc` \ really_final_env -> - - returnTc (really_final_env, foldr ThenBinds EmptyBinds binds) + returnTc final_env where (tyvar_rn_names, tycon_names_w_arities, class_names) = get_binders decls @@ -209,10 +191,10 @@ fmt_decl decl Edges in Type/Class decls ~~~~~~~~~~~~~~~~~~~~~~~~~ \begin{code} -mk_edges (TyD (TyData ctxt name _ condecls _ _ _)) - = (uniqueOf name, set_to_bag (get_ctxt ctxt `unionUniqSets` get_cons condecls)) -mk_edges (TyD (TyNew ctxt name _ condecl _ _ _)) - = (uniqueOf name, set_to_bag (get_ctxt ctxt `unionUniqSets` get_cons condecl)) +mk_edges (TyD (TyData ctxt name _ condecls derivs _ _)) + = (uniqueOf name, set_to_bag (get_ctxt ctxt `unionUniqSets` get_cons condecls `unionUniqSets` get_deriv derivs)) +mk_edges (TyD (TyNew ctxt name _ condecl derivs _ _)) + = (uniqueOf name, set_to_bag (get_ctxt ctxt `unionUniqSets` get_cons condecl `unionUniqSets` get_deriv derivs)) mk_edges (TyD (TySynonym name _ rhs _)) = (uniqueOf name, set_to_bag (get_ty rhs)) mk_edges (ClD (ClassDecl ctxt name _ sigs _ _ _)) @@ -221,6 +203,9 @@ mk_edges (ClD (ClassDecl ctxt name _ sigs _ _ _)) get_ctxt ctxt = unionManyUniqSets (map (set_name.fst) ctxt) +get_deriv Nothing = emptyUniqSet +get_deriv (Just clss) = unionManyUniqSets (map set_name clss) + get_cons cons = unionManyUniqSets (map get_con cons) where diff --git a/ghc/compiler/typecheck/TcTyDecls.lhs b/ghc/compiler/typecheck/TcTyDecls.lhs index b117f2f..e248b90 100644 --- a/ghc/compiler/typecheck/TcTyDecls.lhs +++ b/ghc/compiler/typecheck/TcTyDecls.lhs @@ -23,20 +23,22 @@ import HsSyn ( TyDecl(..), ConDecl(..), BangType(..), HsExpr(..), import RnHsSyn ( RenamedTyDecl(..), RenamedConDecl(..), RnName{-instance Outputable-} ) -import TcHsSyn ( mkHsTyLam, mkHsDictLam, tcIdType, zonkId, +import TcHsSyn ( mkHsTyLam, mkHsDictLam, tcIdType, TcHsBinds(..), TcIdOcc(..) ) import Inst ( newDicts, InstOrigin(..), Inst ) import TcMonoType ( tcMonoTypeKind, tcMonoType, tcPolyType, tcContext ) +import TcSimplify ( tcSimplifyThetas ) import TcType ( tcInstTyVars, tcInstType, tcInstId ) import TcEnv ( tcLookupTyCon, tcLookupTyVar, tcLookupClass, - newLocalId, newLocalIds + newLocalId, newLocalIds, tcLookupClassByKey ) import TcMonad hiding ( rnMtoTcM ) import TcKind ( TcKind, unifyKind, mkTcArrowKind, mkTcTypeKind ) -import Class ( GenClass{-instance Eq-} ) -import Id ( mkDataCon, dataConSig, mkRecordSelId, +import PprType ( GenClass, GenType{-instance Outputable-} ) +import Class ( GenClass{-instance Eq-}, classInstEnv ) +import Id ( mkDataCon, dataConSig, mkRecordSelId, idType, dataConFieldLabels, dataConStrictMarks, StrictnessMark(..), GenId{-instance NamedThing-} @@ -47,18 +49,21 @@ import SpecEnv ( SpecEnv(..), nullSpecEnv ) import Name ( nameSrcLoc, isLocallyDefinedName, getSrcLoc, Name{-instance Ord3-} ) +import Outputable ( Outputable(..), interpp'SP ) import Pretty import TyCon ( TyCon, NewOrData(..), mkSynTyCon, mkDataTyCon, isDataTyCon, - isNewTyCon, tyConDataCons + isNewTyCon, isSynTyCon, tyConDataCons ) -import Type ( typeKind, getTyVar, tyVarsOfTypes, eqTy, +import Type ( GenType, -- instances + typeKind, getTyVar, tyVarsOfTypes, eqTy, splitSigmaTy, applyTyCon, mkTyVarTys, mkForAllTys, mkFunTy, splitFunTy, mkTyVarTy, getTyVar_maybe ) +import PprType ( GenTyVar{-instance Outputable-}{-ToDo:possibly rm-} ) import TyVar ( tyVarKind, elementOfTyVarSet, GenTyVar{-instance Eq-} ) import Unique ( Unique {- instance Eq -}, evalClassKey ) import UniqSet ( emptyUniqSet, mkUniqSet, uniqSetToList, unionManyUniqSets, UniqSet(..) ) -import Util ( equivClasses, zipEqual, panic, assertPanic ) +import Util ( equivClasses, zipEqual, nOfThem, panic, assertPanic ) \end{code} \begin{code} @@ -162,8 +167,15 @@ Generating constructor/selector bindings for data declarations ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ \begin{code} -mkDataBinds :: TyCon -> TcM s ([Id], TcHsBinds s) -mkDataBinds tycon +mkDataBinds :: [TyCon] -> TcM s ([Id], TcHsBinds s) +mkDataBinds [] = returnTc ([], EmptyBinds) +mkDataBinds (tycon : tycons) + | isSynTyCon tycon = mkDataBinds tycons + | otherwise = mkDataBinds_one tycon `thenTc` \ (ids1, b1) -> + mkDataBinds tycons `thenTc` \ (ids2, b2) -> + returnTc (ids1++ids2, b1 `ThenBinds` b2) + +mkDataBinds_one tycon = ASSERT( isDataTyCon tycon || isNewTyCon tycon ) mapAndUnzipTc mkConstructor data_cons `thenTc` \ (con_ids, con_binds) -> mapAndUnzipTc (mkRecordSelector tycon) groups `thenTc` \ (sel_ids, sel_binds) -> @@ -215,48 +227,49 @@ mkConstructor con_id = returnTc (con_id, EmptyMonoBinds) | otherwise -- It is locally defined - = tcInstId con_id `thenNF_Tc` \ (tyvars, theta, tau) -> - newDicts DataDeclOrigin theta `thenNF_Tc` \ (_, dicts) -> + = tcInstId con_id `thenNF_Tc` \ (tc_tyvars, tc_theta, tc_tau) -> + newDicts DataDeclOrigin tc_theta `thenNF_Tc` \ (_, dicts) -> let - (arg_tys, result_ty) = splitFunTy tau - n_args = length arg_tys + (tc_arg_tys, tc_result_ty) = splitFunTy tc_tau + n_args = length tc_arg_tys in - newLocalIds (take n_args (repeat SLIT("con"))) arg_tys - `thenNF_Tc` \ args -> + newLocalIds (nOfThem n_args SLIT("con")) tc_arg_tys `thenNF_Tc` \ args -> - -- Check that all the types of all the strict arguments are in Data. - -- This is trivially true of everything except type variables, for - -- which we must check the context. + -- Check that all the types of all the strict arguments are in Eval + tcLookupClassByKey evalClassKey `thenNF_Tc` \ eval_clas -> let - strict_marks = dataConStrictMarks con_id - strict_args = [arg | (arg, MarkedStrict) <- args `zipEqual` strict_marks] - - data_tyvars = -- The tyvars in the constructor's context that are arguments - -- to the Data class - [getTyVar "mkConstructor" ty - | (clas,ty) <- theta, uniqueOf clas == evalClassKey] - - check_data arg = case getTyVar_maybe (tcIdType arg) of - Nothing -> returnTc () -- Not a tyvar, so OK - Just tyvar -> checkTc (tyvar `elem` data_tyvars) (missingDataErr tyvar) + (_,theta,tau) = splitSigmaTy (idType con_id) + (arg_tys, _) = splitFunTy tau + strict_marks = dataConStrictMarks con_id + eval_theta = [ (eval_clas,arg_ty) + | (arg_ty, MarkedStrict) <- zipEqual "strict_args" + arg_tys strict_marks + ] in - mapTc check_data strict_args `thenTc_` + tcSimplifyThetas classInstEnv theta eval_theta `thenTc` \ eval_theta' -> + checkTc (null eval_theta') + (missingEvalErr con_id eval_theta') `thenTc_` + -- Build the data constructor let - con_rhs = mkHsTyLam tyvars $ + con_rhs = mkHsTyLam tc_tyvars $ mkHsDictLam dicts $ mk_pat_match args $ - mk_case strict_args $ - HsCon con_id (mkTyVarTys tyvars) (map HsVar args) + mk_case (zipEqual "strict_args" args strict_marks) $ + HsCon con_id (mkTyVarTys tc_tyvars) (map HsVar args) mk_pat_match [] body = body - mk_pat_match (arg:args) body = HsLam (PatMatch (VarPat arg) (SimpleMatch (mk_pat_match args body))) + mk_pat_match (arg:args) body = HsLam $ + PatMatch (VarPat arg) $ + SimpleMatch (mk_pat_match args body) mk_case [] body = body - mk_case (arg:args) body = HsCase (HsVar arg) - [PatMatch (VarPat arg) (SimpleMatch (mk_case args body))] - src_loc + mk_case ((arg,MarkedStrict):args) body = HsCase (HsVar arg) + [PatMatch (VarPat arg) $ + SimpleMatch (mk_case args body)] + src_loc + mk_case (_:args) body = mk_case args body src_loc = nameSrcLoc (getName con_id) in @@ -367,8 +380,7 @@ tcConDecl tycon tyvars ctxt (RecConDecl name fields src_loc) arg_tys = [ty | (_, ty, _) <- field_label_infos] field_labels = [ mkFieldLabel (getName name) ty tag - | ((name, ty, _), tag) <- field_label_infos `zip` allFieldLabelTags - ] + | ((name, ty, _), tag) <- field_label_infos `zip` allFieldLabelTags ] data_con = mkDataCon (getName name) stricts @@ -436,6 +448,8 @@ tyNewCtxt tycon_name sty fieldTypeMisMatch field_name sty = ppSep [ppStr "Declared types differ for field", ppr sty field_name] -missingDataErr tyvar sty - = ppStr "Missing `data' (???)" -- ToDo: improve +missingEvalErr con eval_theta sty + = ppCat [ppStr "Missing Eval context for constructor", + ppQuote (ppr sty con), + ppStr ":", ppr sty eval_theta] \end{code} diff --git a/ghc/compiler/typecheck/TcType.lhs b/ghc/compiler/typecheck/TcType.lhs index 44fc091..0a602c7 100644 --- a/ghc/compiler/typecheck/TcType.lhs +++ b/ghc/compiler/typecheck/TcType.lhs @@ -20,12 +20,12 @@ module TcType ( tcInstTyVars, -- TyVar -> NF_TcM s (TcTyVar s) tcInstSigTyVars, - tcInstType, tcInstTcType, tcInstTheta, tcInstId, + tcInstType, tcInstTheta, tcInstId, - zonkTcTyVars, -- TcTyVarSet s -> NF_TcM s (TcTyVarSet s) - zonkTcType, -- TcType s -> NF_TcM s (TcType s) - zonkTcTypeToType, -- TcType s -> NF_TcM s Type - zonkTcTyVarToTyVar -- TcTyVar s -> NF_TcM s TyVar + zonkTcTyVars, + zonkTcType, + zonkTcTypeToType, + zonkTcTyVarToTyVar ) where @@ -37,6 +37,7 @@ import Type ( Type(..), ThetaType(..), GenType(..), splitForAllTy, splitRhoTy ) import TyVar ( TyVar(..), GenTyVar(..), TyVarSet(..), GenTyVarSet(..), + TyVarEnv(..), lookupTyVarEnv, addOneToTyVarEnv, mkTyVarEnv, tyVarSetToList ) @@ -48,11 +49,13 @@ import TcKind ( TcKind ) import TcMonad hiding ( rnMtoTcM ) import Usage ( Usage(..), GenUsage, UVar(..), duffUsage ) +import TysWiredIn ( voidTy ) + import Ubiq import Unique ( Unique ) import UniqFM ( UniqFM ) import Maybes ( assocMaybe ) -import Util ( panic, pprPanic ) +import Util ( zipEqual, nOfThem, panic, pprPanic ) import Outputable ( Outputable(..) ) -- Debugging messages import PprType ( GenTyVar, GenType ) @@ -115,7 +118,7 @@ newTyVarTy kind returnNF_Tc (TyVarTy tc_tyvar) newTyVarTys :: Int -> Kind -> NF_TcM s [TcType s] -newTyVarTys n kind = mapNF_Tc newTyVarTy (take n (repeat kind)) +newTyVarTys n kind = mapNF_Tc newTyVarTy (nOfThem n kind) @@ -132,7 +135,7 @@ inst_tyvars initial_cts tyvars let tys = map TyVarTy tc_tyvars in - returnNF_Tc (tc_tyvars, tys, tyvars `zip` tys) + returnNF_Tc (tc_tyvars, tys, zipEqual "inst_tyvars" tyvars tys) inst_tyvar initial_cts (TyVar _ kind name _) = tcGetUnique `thenNF_Tc` \ uniq -> @@ -152,9 +155,41 @@ of local functions). In the future @tcInstType@ may try to be clever about not instantiating constant sub-parts. \begin{code} -tcInstType :: [(TyVar,TcType s)] -> Type -> NF_TcM s (TcType s) +tcInstType :: [(GenTyVar flexi,TcType s)] + -> GenType (GenTyVar flexi) UVar + -> NF_TcM s (TcType s) tcInstType tenv ty_to_inst - = do [(uniq,ty) | (TyVar uniq _ _ _, ty) <- tenv] ty_to_inst + = tcConvert bind_fn occ_fn (mkTyVarEnv tenv) ty_to_inst + where + bind_fn = inst_tyvar DontBind + occ_fn env tyvar = case lookupTyVarEnv env tyvar of + Just ty -> returnNF_Tc ty + Nothing -> pprPanic "tcInstType:" (ppAboves [ppr PprDebug ty_to_inst, + ppr PprDebug tyvar]) + +zonkTcTyVarToTyVar :: TcTyVar s -> NF_TcM s TyVar +zonkTcTyVarToTyVar tyvar + = zonkTcTyVar tyvar `thenNF_Tc` \ (TyVarTy tyvar') -> + returnNF_Tc (tcTyVarToTyVar tyvar') + +zonkTcTypeToType :: TyVarEnv Type -> TcType s -> NF_TcM s Type +zonkTcTypeToType env ty + = tcConvert zonkTcTyVarToTyVar occ_fn env ty + where + occ_fn env tyvar + = tcReadTyVar tyvar `thenNF_Tc` \ maybe_ty -> + case maybe_ty of + BoundTo (TyVarTy tyvar') -> lookup env tyvar' + BoundTo other_ty -> tcConvert zonkTcTyVarToTyVar occ_fn env other_ty + other -> lookup env tyvar + + lookup env tyvar = case lookupTyVarEnv env tyvar of + Just ty -> returnNF_Tc ty + Nothing -> returnNF_Tc voidTy -- Unbound type variables go to Void + + +tcConvert bind_fn occ_fn env ty_to_convert + = do env ty_to_convert where do env (TyConTy tycon usage) = returnNF_Tc (TyConTy tycon usage) @@ -173,21 +208,19 @@ tcInstType tenv ty_to_inst do env (DictTy clas ty usage)= do env ty `thenNF_Tc` \ ty' -> returnNF_Tc (DictTy clas ty' usage) - do env (TyVarTy tv@(TyVar uniq kind name _)) - = case assocMaybe env uniq of - Just tc_ty -> returnNF_Tc tc_ty - Nothing -> pprPanic "tcInstType:" (ppAboves [ppr PprDebug tenv, - ppr PprDebug ty_to_inst, ppr PprDebug tv]) + do env (ForAllUsageTy u us ty) = do env ty `thenNF_Tc` \ ty' -> + returnNF_Tc (ForAllUsageTy u us ty') + + -- The two interesting cases! + do env (TyVarTy tv) = occ_fn env tv - do env (ForAllTy tyvar@(TyVar uniq kind name _) ty) - = inst_tyvar DontBind tyvar `thenNF_Tc` \ tc_tyvar -> + do env (ForAllTy tyvar ty) + = bind_fn tyvar `thenNF_Tc` \ tyvar' -> let - new_env = (uniq, TyVarTy tc_tyvar) : env + new_env = addOneToTyVarEnv env tyvar (TyVarTy tyvar') in - do new_env ty `thenNF_Tc` \ ty' -> - returnNF_Tc (ForAllTy tc_tyvar ty') - - -- ForAllUsage impossible + do new_env ty `thenNF_Tc` \ ty' -> + returnNF_Tc (ForAllTy tyvar' ty') tcInstTheta :: [(TyVar,TcType s)] -> ThetaType -> NF_TcM s (TcThetaType s) @@ -214,39 +247,6 @@ tcInstId id (theta', tau') = splitRhoTy rho' in returnNF_Tc (tyvars', theta', tau') - - -tcInstTcType :: [(TcTyVar s,TcType s)] -> TcType s -> NF_TcM s (TcType s) -tcInstTcType tenv ty_to_inst - = do [(uniq,ty) | (TyVar uniq _ _ _, ty) <- tenv] ty_to_inst - where - do env ty@(TyConTy tycon usage) = returnNF_Tc ty - --- Could do clever stuff here to avoid instantiating constant types - do env (SynTy tycon tys ty) = mapNF_Tc (do env) tys `thenNF_Tc` \ tys' -> - do env ty `thenNF_Tc` \ ty' -> - returnNF_Tc (SynTy tycon tys' ty') - - do env (FunTy arg res usage) = do env arg `thenNF_Tc` \ arg' -> - do env res `thenNF_Tc` \ res' -> - returnNF_Tc (FunTy arg' res' usage) - - do env (AppTy fun arg) = do env fun `thenNF_Tc` \ fun' -> - do env arg `thenNF_Tc` \ arg' -> - returnNF_Tc (AppTy fun' arg') - - do env (DictTy clas ty usage)= do env ty `thenNF_Tc` \ ty' -> - returnNF_Tc (DictTy clas ty' usage) - - do env ty@(TyVarTy (TyVar uniq kind name _)) - = case assocMaybe env uniq of - Just tc_ty -> returnNF_Tc tc_ty - Nothing -> returnNF_Tc ty - - do env (ForAllTy (TyVar uniq kind name _) ty) = panic "tcInstTcType" - - -- ForAllUsage impossible - \end{code} Reading and writing TcTyVars @@ -299,71 +299,51 @@ short_out other_ty = returnNF_Tc other_ty Zonking ~~~~~~~ -@zonkTcTypeToType@ converts from @TcType@ to @Type@. It follows through all -the substitutions of course. - \begin{code} -zonkTcTypeToType :: TcType s -> NF_TcM s Type -zonkTcTypeToType ty = zonk tcTyVarToTyVar ty - -zonkTcType :: TcType s -> NF_TcM s (TcType s) -zonkTcType ty = zonk (\tyvar -> tyvar) ty - zonkTcTyVars :: TcTyVarSet s -> NF_TcM s (TcTyVarSet s) zonkTcTyVars tyvars - = mapNF_Tc (zonk_tv (\tyvar -> tyvar)) - (tyVarSetToList tyvars) `thenNF_Tc` \ tys -> + = mapNF_Tc zonkTcTyVar (tyVarSetToList tyvars) `thenNF_Tc` \ tys -> returnNF_Tc (tyVarsOfTypes tys) -zonkTcTyVarToTyVar :: TcTyVar s -> NF_TcM s TyVar -zonkTcTyVarToTyVar tyvar - = zonk_tv_to_tv tcTyVarToTyVar tyvar +zonkTcTyVar :: TcTyVar s -> NF_TcM s (TcType s) +zonkTcTyVar tyvar + = tcReadTyVar tyvar `thenNF_Tc` \ maybe_ty -> + case maybe_ty of + BoundTo ty@(TyVarTy tyvar') -> returnNF_Tc ty + BoundTo other -> zonkTcType other + other -> returnNF_Tc (TyVarTy tyvar) +zonkTcType :: TcType s -> NF_TcM s (TcType s) -zonk tyvar_fn (TyVarTy tyvar) - = zonk_tv tyvar_fn tyvar +zonkTcType (TyVarTy tyvar) = zonkTcTyVar tyvar -zonk tyvar_fn (AppTy ty1 ty2) - = zonk tyvar_fn ty1 `thenNF_Tc` \ ty1' -> - zonk tyvar_fn ty2 `thenNF_Tc` \ ty2' -> +zonkTcType (AppTy ty1 ty2) + = zonkTcType ty1 `thenNF_Tc` \ ty1' -> + zonkTcType ty2 `thenNF_Tc` \ ty2' -> returnNF_Tc (AppTy ty1' ty2') -zonk tyvar_fn (TyConTy tc u) +zonkTcType (TyConTy tc u) = returnNF_Tc (TyConTy tc u) -zonk tyvar_fn (SynTy tc tys ty) - = mapNF_Tc (zonk tyvar_fn) tys `thenNF_Tc` \ tys' -> - zonk tyvar_fn ty `thenNF_Tc` \ ty' -> +zonkTcType (SynTy tc tys ty) + = mapNF_Tc zonkTcType tys `thenNF_Tc` \ tys' -> + zonkTcType ty `thenNF_Tc` \ ty' -> returnNF_Tc (SynTy tc tys' ty') -zonk tyvar_fn (ForAllTy tv ty) - = zonk_tv_to_tv tyvar_fn tv `thenNF_Tc` \ tv' -> - zonk tyvar_fn ty `thenNF_Tc` \ ty' -> +zonkTcType (ForAllTy tv ty) + = zonkTcTyVar tv `thenNF_Tc` \ (TyVarTy tv') -> -- Should be a tyvar! + zonkTcType ty `thenNF_Tc` \ ty' -> returnNF_Tc (ForAllTy tv' ty') -zonk tyvar_fn (ForAllUsageTy uv uvs ty) +zonkTcType (ForAllUsageTy uv uvs ty) = panic "zonk:ForAllUsageTy" -zonk tyvar_fn (FunTy ty1 ty2 u) - = zonk tyvar_fn ty1 `thenNF_Tc` \ ty1' -> - zonk tyvar_fn ty2 `thenNF_Tc` \ ty2' -> +zonkTcType (FunTy ty1 ty2 u) + = zonkTcType ty1 `thenNF_Tc` \ ty1' -> + zonkTcType ty2 `thenNF_Tc` \ ty2' -> returnNF_Tc (FunTy ty1' ty2' u) -zonk tyvar_fn (DictTy c ty u) - = zonk tyvar_fn ty `thenNF_Tc` \ ty' -> +zonkTcType (DictTy c ty u) + = zonkTcType ty `thenNF_Tc` \ ty' -> returnNF_Tc (DictTy c ty' u) - - -zonk_tv tyvar_fn tyvar - = tcReadTyVar tyvar `thenNF_Tc` \ maybe_ty -> - case maybe_ty of - BoundTo ty -> zonk tyvar_fn ty - other -> returnNF_Tc (TyVarTy (tyvar_fn tyvar)) - - -zonk_tv_to_tv tyvar_fn tyvar - = zonk_tv tyvar_fn tyvar `thenNF_Tc` \ ty -> - case getTyVar_maybe ty of - Nothing -> panic "zonk_tv_to_tv" - Just tyvar -> returnNF_Tc tyvar \end{code} diff --git a/ghc/compiler/typecheck/Unify.lhs b/ghc/compiler/typecheck/Unify.lhs index 11d0545..39c27f3 100644 --- a/ghc/compiler/typecheck/Unify.lhs +++ b/ghc/compiler/typecheck/Unify.lhs @@ -330,9 +330,9 @@ expectedFunErr ty sty unifyKindErr tyvar ty sty = ppHang (ppStr "Compiler bug: kind mis-match between") - 4 (ppSep [ppr sty tyvar, ppLparen, ppr sty (tyVarKind tyvar), ppRparen, + 4 (ppSep [ppCat [ppr sty tyvar, ppStr "::", ppr sty (tyVarKind tyvar)], ppStr "and", - ppr sty ty, ppLparen, ppr sty (typeKind ty), ppRparen]) + ppCat [ppr sty ty, ppStr "::", ppr sty (typeKind ty)]]) unifyDontBindErr tyvar ty sty = ppHang (ppStr "Couldn't match the *signature/existential* type variable") diff --git a/ghc/compiler/types/Class.lhs b/ghc/compiler/types/Class.lhs index e5db71f..0cf92a5 100644 --- a/ghc/compiler/types/Class.lhs +++ b/ghc/compiler/types/Class.lhs @@ -36,6 +36,7 @@ import TyVar ( TyVar(..), GenTyVar ) import Usage ( GenUsage, Usage(..), UVar(..) ) import Maybes ( assocMaybe, Maybe ) +import Name ( changeUnique ) import Unique -- Keys for built-in classes import Pretty ( Pretty(..), ppCat{-ToDo:rm-}, ppPStr{-ditto-} ) import PprStyle ( PprStyle ) @@ -117,7 +118,7 @@ mkClass :: Unique -> Name -> TyVar mkClass uniq full_name tyvar super_classes superdict_sels class_ops dict_sels defms class_insts - = Class uniq full_name tyvar + = Class uniq (changeUnique full_name uniq) tyvar super_classes superdict_sels class_ops dict_sels defms class_insts @@ -233,8 +234,7 @@ We compare @Classes@ by their keys (which include @Uniques@). \begin{code} instance Ord3 (GenClass tyvar uvar) where - cmp (Class k1 _ _ _ _ _ _ _ _ _) (Class k2 _ _ _ _ _ _ _ _ _) - = cmp k1 k2 + cmp (Class k1 _ _ _ _ _ _ _ _ _) (Class k2 _ _ _ _ _ _ _ _ _) = cmp k1 k2 instance Eq (GenClass tyvar uvar) where (Class k1 _ _ _ _ _ _ _ _ _) == (Class k2 _ _ _ _ _ _ _ _ _) = k1 == k2 diff --git a/ghc/compiler/types/Kind.lhs b/ghc/compiler/types/Kind.lhs index ad6875d..249ad6c 100644 --- a/ghc/compiler/types/Kind.lhs +++ b/ghc/compiler/types/Kind.lhs @@ -58,9 +58,13 @@ UnboxedTypeKind `hasMoreBoxityInfo` UnboxedTypeKind = True TypeKind `hasMoreBoxityInfo` TypeKind = True -kind1 `hasMoreBoxityInfo` kind2 = ASSERT( notArrowKind kind1 && - notArrowKind kind2 ) - False +kind1@(ArrowKind _ _) `hasMoreBoxityInfo` kind2@(ArrowKind _ _) = ASSERT( kind1 == kind2 ) + True + -- The two kinds can be arrow kinds; for example when unifying + -- (m1 Int) and (m2 Int) we end up unifying m1 and m2, which should + -- have the same kind. + +kind1 `hasMoreBoxityInfo` kind2 = False -- Not exported notArrowKind (ArrowKind _ _) = False diff --git a/ghc/compiler/types/PprType.lhs b/ghc/compiler/types/PprType.lhs index c066295..4720605 100644 --- a/ghc/compiler/types/PprType.lhs +++ b/ghc/compiler/types/PprType.lhs @@ -44,7 +44,7 @@ import CStrings ( identToC ) import CmdLineOpts ( opt_OmitInterfacePragmas ) import Maybes ( maybeToBool ) import Name ( isLexVarSym, isLexSpecialSym, isPreludeDefined, origName, moduleOf, - Name{-instance Outputable-} + nameOrigName, nameOf, Name{-instance Outputable-} ) import Outputable ( ifPprShowAll, interpp'SP ) import PprEnv @@ -181,9 +181,7 @@ ppr_ty sty env ctxt_prec (DictTy clas ty usage) -- Some help functions ppr_corner sty env ctxt_prec (TyConTy FunTyCon usage) arg_tys | length arg_tys == 2 - = (if length arg_tys /= 2 then pprTrace "ppr_corner:" (ppCat (map (ppr_ty sty env ctxt_prec) arg_tys)) else id) $ - ASSERT(length arg_tys == 2) - ppr_ty sty env ctxt_prec (FunTy ty1 ty2 usage) + = ppr_ty sty env ctxt_prec (FunTy ty1 ty2 usage) where (ty1:ty2:_) = arg_tys @@ -265,11 +263,11 @@ maybeParen ctxt_prec inner_prec pretty pprGenTyVar sty (TyVar uniq kind name usage) = case sty of PprInterface -> pp_u - _ -> ppBeside pp_name pp_u + _ -> ppBesides [pp_name, ppStr "{-", pp_u, ppStr "-}"] where - pp_u = pprUnique10 uniq + pp_u = pprUnique uniq pp_name = case name of - Just n -> ppr sty n + Just n -> ppPStr (nameOf (nameOrigName n)) Nothing -> case kind of TypeKind -> ppChar 'o' BoxedTypeKind -> ppChar 't' diff --git a/ghc/compiler/types/TyCon.lhs b/ghc/compiler/types/TyCon.lhs index c975f35..d406196 100644 --- a/ghc/compiler/types/TyCon.lhs +++ b/ghc/compiler/types/TyCon.lhs @@ -54,9 +54,11 @@ import Name ( Name, RdrName(..), appendRdr, nameUnique, mkTupleTyConName, mkFunTyConName ) import Unique ( Unique, funTyConKey, mkTupleTyConUnique ) +import PrelInfo ( intDataCon, charDataCon ) import Pretty ( Pretty(..), PrettyRep ) import PprStyle ( PprStyle ) import SrcLoc ( SrcLoc, mkBuiltinSrcLoc ) +import Unique ( intDataConKey, charDataConKey ) import Util ( panic, panic#, nOfThem, isIn, Ord3(..) ) \end{code} diff --git a/ghc/compiler/types/TyVar.lhs b/ghc/compiler/types/TyVar.lhs index cddcdcb..88f1e85 100644 --- a/ghc/compiler/types/TyVar.lhs +++ b/ghc/compiler/types/TyVar.lhs @@ -35,7 +35,7 @@ import UniqFM ( emptyUFM, listToUFM, addToUFM, lookupUFM, plusUFM, sizeUFM, UniqFM ) import Maybes ( Maybe(..) ) -import Name ( mkLocalName, Name, RdrName(..) ) +import Name ( mkLocalName, changeUnique, Name, RdrName(..) ) import Pretty ( Pretty(..), PrettyRep, ppBeside, ppPStr ) import PprStyle ( PprStyle ) --import Outputable ( Outputable(..), NamedThing(..), ExportFlag(..) ) @@ -63,7 +63,7 @@ Simple construction and analysis functions mkTyVar :: Name -> Unique -> Kind -> TyVar mkTyVar name uniq kind = TyVar uniq kind - (Just name) + (Just (changeUnique name uniq)) usageOmega tyVarKind :: GenTyVar flexi -> Kind @@ -147,6 +147,6 @@ instance Uniquable (GenTyVar a) where uniqueOf (TyVar u _ _ _) = u instance NamedThing (GenTyVar a) where - getName (TyVar _ _ (Just n) _) = n - getName (TyVar u _ _ _) = mkLocalName u (showUnique u) mkUnknownSrcLoc + getName (TyVar _ _ (Just n) _) = n + getName (TyVar u _ _ _) = mkLocalName u (showUnique u) mkUnknownSrcLoc \end{code} diff --git a/ghc/compiler/types/Type.lhs b/ghc/compiler/types/Type.lhs index 5c06b0f..e777415 100644 --- a/ghc/compiler/types/Type.lhs +++ b/ghc/compiler/types/Type.lhs @@ -6,23 +6,27 @@ module Type ( mkTyVarTy, mkTyVarTys, getTyVar, getTyVar_maybe, isTyVarTy, mkAppTy, mkAppTys, splitAppTy, - mkFunTy, mkFunTys, splitFunTy, splitFunTyWithDictsAsArgs, - getFunTy_maybe, + mkFunTy, mkFunTys, splitFunTy, splitFunTyExpandingDicts, + getFunTy_maybe, getFunTyExpandingDicts_maybe, mkTyConTy, getTyCon_maybe, applyTyCon, mkSynTy, mkForAllTy, mkForAllTys, getForAllTy_maybe, splitForAllTy, mkForAllUsageTy, getForAllUsageTy, applyTy, - +#ifdef DEBUG + expandTy, -- only let out for debugging (ToDo: rm?) +#endif isPrimType, isUnboxedType, typePrimRep, RhoType(..), SigmaType(..), ThetaType(..), mkDictTy, - mkRhoTy, splitRhoTy, + mkRhoTy, splitRhoTy, mkTheta, mkSigmaTy, splitSigmaTy, maybeAppTyCon, getAppTyCon, - maybeAppDataTyCon, getAppDataTyCon, + maybeAppDataTyCon, getAppDataTyCon, getAppSpecDataTyCon, + maybeAppDataTyConExpandingDicts, maybeAppSpecDataTyConExpandingDicts, + getAppDataTyConExpandingDicts, getAppSpecDataTyConExpandingDicts, maybeBoxedPrimType, matchTy, matchTys, eqTy, eqSimpleTy, eqSimpleTheta, @@ -59,10 +63,22 @@ import Usage ( usageOmega, GenUsage, Usage(..), UVar(..), UVarEnv(..), eqUsage ) -- others +import Maybes ( maybeToBool ) import PrimRep ( PrimRep(..) ) -import Util ( thenCmp, zipEqual, panic, panic#, assertPanic, +import Util ( thenCmp, zipEqual, panic, panic#, assertPanic, pprTrace{-ToDo:rm-}, pprPanic{-ToDo:rm-}, Ord3(..){-instances-} ) +-- ToDo:rm all these +import {-mumble-} + Pretty +import {-mumble-} + PprStyle +import {-mumble-} + PprType (pprType ) +import {-mumble-} + UniqFM (ufmToList ) +import {-mumble-} + Unique (pprUnique ) \end{code} Data types @@ -204,6 +220,13 @@ mkFunTy arg res = FunTy arg res usageOmega mkFunTys :: [GenType t u] -> GenType t u -> GenType t u mkFunTys ts t = foldr (\ f a -> FunTy f a usageOmega) t ts + -- getFunTy_maybe and splitFunTy *must* have the general type given, which + -- means they *can't* do the DictTy jiggery-pokery that + -- *is* sometimes required. Hence we also have the ExpandingDicts variants + -- The relationship between these + -- two functions is like that between eqTy and eqSimpleTy. + -- ToDo: NUKE when we do dicts via newtype + getFunTy_maybe :: GenType t u -> Maybe (GenType t u, GenType t u) getFunTy_maybe (FunTy arg result _) = Just (arg,result) getFunTy_maybe (AppTy (AppTy (TyConTy tycon _) arg) res) @@ -211,36 +234,25 @@ getFunTy_maybe (AppTy (AppTy (TyConTy tycon _) arg) res) getFunTy_maybe (SynTy _ _ t) = getFunTy_maybe t getFunTy_maybe other = Nothing -splitFunTy :: GenType t u -> ([GenType t u], GenType t u) -splitFunTyWithDictsAsArgs :: Type -> ([Type], Type) - -- splitFunTy *must* have the general type given, which - -- means it *can't* do the DictTy jiggery-pokery that - -- *is* sometimes required. The relationship between these - -- two functions is like that between eqTy and eqSimpleTy. +getFunTyExpandingDicts_maybe :: Type -> Maybe (Type, Type) +getFunTyExpandingDicts_maybe (FunTy arg result _) = Just (arg,result) +getFunTyExpandingDicts_maybe + (AppTy (AppTy (TyConTy tycon _) arg) res) | isFunTyCon tycon = Just (arg, res) +getFunTyExpandingDicts_maybe (SynTy _ _ t) = getFunTyExpandingDicts_maybe t +getFunTyExpandingDicts_maybe ty@(DictTy _ _ _) = getFunTyExpandingDicts_maybe (expandTy ty) +getFunTyExpandingDicts_maybe other = Nothing -splitFunTy t = go t [] - where - go (FunTy arg res _) ts = go res (arg:ts) - go (AppTy (AppTy (TyConTy tycon _) arg) res) ts - | isFunTyCon tycon = go res (arg:ts) - go (SynTy _ _ t) ts = go t ts - go t ts = (reverse ts, t) +splitFunTy :: GenType t u -> ([GenType t u], GenType t u) +splitFunTyExpandingDicts :: Type -> ([Type], Type) -splitFunTyWithDictsAsArgs t = go t [] +splitFunTy t = split_fun_ty getFunTy_maybe t +splitFunTyExpandingDicts t = split_fun_ty getFunTyExpandingDicts_maybe t + +split_fun_ty get t = go t [] where - go (FunTy arg res _) ts = go res (arg:ts) - go (AppTy (AppTy (TyConTy tycon _) arg) res) ts - | isFunTyCon tycon = go res (arg:ts) - go (SynTy _ _ t) ts = go t ts - - -- For a dictionary type we try expanding it to see if we get a simple - -- function; if so we thunder on; if not we throw away the expansion. - go t@(DictTy _ _ _) ts | null ts' = (reverse ts, t) - | otherwise = (reverse ts ++ ts', t') - where - (ts', t') = go (expandTy t) [] - - go t ts = (reverse ts, t) + go t ts = case (get t) of + Just (arg,res) -> go res (arg:ts) + Nothing -> (reverse ts, t) \end{code} \begin{code} @@ -254,16 +266,23 @@ applyTyCon tycon tys = ASSERT (not (isSynTyCon tycon)) foldl AppTy (TyConTy tycon usageOmega) tys -getTyCon_maybe :: GenType t u -> Maybe TyCon +getTyCon_maybe :: GenType t u -> Maybe TyCon +--getTyConExpandingDicts_maybe :: Type -> Maybe TyCon + getTyCon_maybe (TyConTy tycon _) = Just tycon getTyCon_maybe (SynTy _ _ t) = getTyCon_maybe t getTyCon_maybe other_ty = Nothing + +--getTyConExpandingDicts_maybe (TyConTy tycon _) = Just tycon +--getTyConExpandingDicts_maybe (SynTy _ _ t) = getTyConExpandingDicts_maybe t +--getTyConExpandingDicts_maybe ty@(DictTy _ _ _) = getTyConExpandingDicts_maybe (expandTy ty) +--getTyConExpandingDicts_maybe other_ty = Nothing \end{code} \begin{code} mkSynTy syn_tycon tys = ASSERT(isSynTyCon syn_tycon) - SynTy syn_tycon tys (instantiateTauTy (zipEqual tyvars tys) body) + SynTy syn_tycon tys (instantiateTauTy (zipEqual "mkSynTy" tyvars tys) body) where (tyvars, body) = getSynTyConDefn syn_tycon \end{code} @@ -302,6 +321,15 @@ splitRhoTy t = = go r ((c,t):ts) go (SynTy _ _ t) ts = go t ts go t ts = (reverse ts, t) + + +mkTheta :: [Type] -> ThetaType + -- recover a ThetaType from the types of some dictionaries +mkTheta dict_tys + = map cvt dict_tys + where + cvt (DictTy clas ty _) = (clas, ty) + cvt other = pprPanic "mkTheta:" (pprType PprDebug other) \end{code} @@ -373,8 +401,15 @@ maybeAppDataTyCon -> Maybe (TyCon, -- the type constructor [GenType tyvar uvar], -- types to which it is applied [Id]) -- its family of data-constructors +maybeAppDataTyConExpandingDicts, maybeAppSpecDataTyConExpandingDicts + :: Type -> Maybe (TyCon, [Type], [Id]) + +maybeAppDataTyCon ty = maybe_app_data_tycon (\x->x) ty +maybeAppDataTyConExpandingDicts ty = maybe_app_data_tycon expandTy ty +maybeAppSpecDataTyConExpandingDicts ty = maybe_app_data_tycon expandTy ty -maybeAppDataTyCon ty + +maybe_app_data_tycon expand ty = case (getTyCon_maybe app_ty) of Just tycon | isDataTyCon tycon && tyConArity tycon == length arg_tys @@ -383,20 +418,28 @@ maybeAppDataTyCon ty other -> Nothing where - (app_ty, arg_tys) = splitAppTy ty + (app_ty, arg_tys) = splitAppTy (expand ty) - -getAppDataTyCon +getAppDataTyCon, getAppSpecDataTyCon :: GenType tyvar uvar -> (TyCon, -- the type constructor [GenType tyvar uvar], -- types to which it is applied [Id]) -- its family of data-constructors +getAppDataTyConExpandingDicts, getAppSpecDataTyConExpandingDicts + :: Type -> (TyCon, [Type], [Id]) + +getAppDataTyCon ty = get_app_data_tycon maybeAppDataTyCon ty +getAppDataTyConExpandingDicts ty = get_app_data_tycon maybeAppDataTyConExpandingDicts ty -getAppDataTyCon ty - = case maybeAppDataTyCon ty of +-- these should work like the UniTyFuns.getUniDataSpecTyCon* things of old (ToDo) +getAppSpecDataTyCon = getAppDataTyCon +getAppSpecDataTyConExpandingDicts = getAppDataTyConExpandingDicts + +get_app_data_tycon maybe ty + = case maybe ty of Just stuff -> stuff #ifdef DEBUG - Nothing -> panic "Type.getAppDataTyCon: " -- (pprGenType PprShowAll ty) + Nothing -> panic "Type.getAppDataTyCon" -- (pprGenType PprShowAll ty) #endif @@ -462,12 +505,98 @@ tyVarsOfTypes tys = foldr (unionTyVarSets.tyVarsOfType) emptyTyVarSet tys Instantiating a type ~~~~~~~~~~~~~~~~~~~~ \begin{code} -applyTy :: Eq t => GenType t u -> GenType t u -> GenType t u +applyTy :: GenType (GenTyVar flexi) uvar + -> GenType (GenTyVar flexi) uvar + -> GenType (GenTyVar flexi) uvar + applyTy (SynTy _ _ fun) arg = applyTy fun arg applyTy (ForAllTy tv ty) arg = instantiateTy [(tv,arg)] ty applyTy other arg = panic "applyTy" +\end{code} -instantiateTy :: Eq t => [(t, GenType t u)] -> GenType t u -> GenType t u +\begin{code} +instantiateTy :: [(GenTyVar flexi, GenType (GenTyVar flexi) uvar)] + -> GenType (GenTyVar flexi) uvar + -> GenType (GenTyVar flexi) uvar + +instantiateTauTy :: Eq tv => + [(tv, GenType tv' u)] + -> GenType tv u + -> GenType tv' u + +applyTypeEnvToTy :: TyVarEnv Type -> SigmaType -> SigmaType + +-- instantiateTauTy works only (a) on types with no ForAlls, +-- and when (b) all the type variables are being instantiated +-- In return it is more polymorphic than instantiateTy + +instant_help ty lookup_tv deflt_tv choose_tycon + if_usage if_forall bound_forall_tv_BAD deflt_forall_tv + = go ty + where + go (TyVarTy tv) = case (lookup_tv tv) of + Nothing -> deflt_tv tv + Just ty -> ty + go ty@(TyConTy tycon usage) = choose_tycon ty tycon usage + go (SynTy tycon tys ty) = SynTy tycon (map go tys) (go ty) + go (FunTy arg res usage) = FunTy (go arg) (go res) usage + go (AppTy fun arg) = AppTy (go fun) (go arg) + go (DictTy clas ty usage) = DictTy clas (go ty) usage + go (ForAllUsageTy uvar bds ty) = if_usage $ + ForAllUsageTy uvar bds (go ty) + go (ForAllTy tv ty) = if_forall $ + (if (bound_forall_tv_BAD && maybeToBool (lookup_tv tv)) then + trace "instantiateTy: unexpected forall hit" + else + \x->x) ForAllTy (deflt_forall_tv tv) (go ty) + +instantiateTy tenv ty + = instant_help ty lookup_tv deflt_tv choose_tycon + if_usage if_forall bound_forall_tv_BAD deflt_forall_tv + where + lookup_tv tv = case [ty | (tv',ty) <- tenv, tv == tv'] of + [] -> Nothing + [ty] -> Just ty + _ -> panic "instantiateTy:lookup_tv" + + deflt_tv tv = TyVarTy tv + choose_tycon ty _ _ = ty + if_usage ty = ty + if_forall ty = ty + bound_forall_tv_BAD = True + deflt_forall_tv tv = tv + +instantiateTauTy tenv ty + = instant_help ty lookup_tv deflt_tv choose_tycon + if_usage if_forall bound_forall_tv_BAD deflt_forall_tv + where + lookup_tv tv = case [ty | (tv',ty) <- tenv, tv == tv'] of + [] -> Nothing + [ty] -> Just ty + _ -> panic "instantiateTauTy:lookup_tv" + + deflt_tv tv = panic "instantiateTauTy" + choose_tycon _ tycon usage = TyConTy tycon usage + if_usage ty = panic "instantiateTauTy:ForAllUsageTy" + if_forall ty = panic "instantiateTauTy:ForAllTy" + bound_forall_tv_BAD = panic "instantiateTauTy:bound_forall_tv" + deflt_forall_tv tv = panic "instantiateTauTy:deflt_forall_tv" + +applyTypeEnvToTy tenv ty + = instant_help ty lookup_tv deflt_tv choose_tycon + if_usage if_forall bound_forall_tv_BAD deflt_forall_tv + where + lookup_tv = lookupTyVarEnv tenv + deflt_tv tv = TyVarTy tv + choose_tycon ty _ _ = ty + if_usage ty = ty + if_forall ty = ty + bound_forall_tv_BAD = False -- ToDo: probably should be True (i.e., no shadowing) + deflt_forall_tv tv = case (lookup_tv tv) of + Nothing -> tv + Just (TyVarTy tv2) -> tv2 + _ -> panic "applyTypeEnvToTy" +{- instantiateTy tenv ty = go ty where @@ -486,12 +615,6 @@ instantiateTy tenv ty go (ForAllUsageTy uvar bds ty) = ForAllUsageTy uvar bds (go ty) - --- instantiateTauTy works only (a) on types with no ForAlls, --- and when (b) all the type variables are being instantiated --- In return it is more polymorphic than instantiateTy - -instantiateTauTy :: Eq t => [(t, GenType t' u)] -> GenType t u -> GenType t' u instantiateTauTy tenv ty = go ty where @@ -504,17 +627,12 @@ instantiateTauTy tenv ty go (AppTy fun arg) = AppTy (go fun) (go arg) go (DictTy clas ty usage) = DictTy clas (go ty) usage -instantiateUsage - :: Ord3 u => [(u, GenType t u')] -> GenType t u -> GenType t u' -instantiateUsage = error "instantiateUsage: not implemented" -\end{code} - -\begin{code} -type TypeEnv = TyVarEnv Type - -applyTypeEnvToTy :: TypeEnv -> SigmaType -> SigmaType applyTypeEnvToTy tenv ty - = mapOverTyVars v_fn ty + = let + result = mapOverTyVars v_fn ty + in +-- pprTrace "applyTypeEnv:" (ppAboves [pprType PprDebug ty, pprType PprDebug result, ppAboves [ppCat [pprUnique u, pprType PprDebug t] | (u,t) <- ufmToList tenv]]) $ + result where v_fn v = case (lookupTyVarEnv tenv v) of Just ty -> ty @@ -538,8 +656,18 @@ mapOverTyVars v_fn ty FunTy a r u -> FunTy (mapper a) (mapper r) u AppTy f a -> AppTy (mapper f) (mapper a) DictTy c t u -> DictTy c (mapper t) u - ForAllTy v t -> ForAllTy v (mapper t) + ForAllTy v t -> case (v_fn v) of + TyVarTy v2 -> ForAllTy v2 (mapper t) + _ -> panic "mapOverTyVars" tc@(TyConTy _ _) -> tc +-} +\end{code} + +\begin{code} +instantiateUsage + :: Ord3 u => [(u, GenType t u')] -> GenType t u -> GenType t u' + +instantiateUsage = panic "instantiateUsage: not implemented" \end{code} At present there are no unboxed non-primitive types, so @@ -591,7 +719,7 @@ matchTys :: [GenType t1 u1] -- Templates -> Maybe [(t1,GenType t2 u2)] -- Matching substitution matchTy ty1 ty2 = match [] [] ty1 ty2 -matchTys tys1 tys2 = match' [] (zipEqual tys1 tys2) +matchTys tys1 tys2 = match' [] (zipEqual "matchTys" tys1 tys2) \end{code} @match@ is the main function. diff --git a/ghc/compiler/utils/Pretty.lhs b/ghc/compiler/utils/Pretty.lhs index 31bad81..e5c20cc 100644 --- a/ghc/compiler/utils/Pretty.lhs +++ b/ghc/compiler/utils/Pretty.lhs @@ -25,7 +25,7 @@ module Pretty ( #endif ppSP, pp'SP, ppLbrack, ppRbrack, ppLparen, ppRparen, ppSemi, ppComma, ppEquals, - ppBracket, ppParens, + ppBracket, ppParens, ppQuote, ppCat, ppBeside, ppBesides, ppAbove, ppAboves, ppNest, ppSep, ppHang, ppInterleave, ppIntersperse, @@ -164,6 +164,7 @@ ppEquals = ppChar '=' ppBracket p = ppBeside ppLbrack (ppBeside p ppRbrack) ppParens p = ppBeside ppLparen (ppBeside p ppRparen) +ppQuote p = ppBeside (ppChar '`') (ppBeside p (ppChar '\'')) ppInterleave sep ps = ppSep (pi ps) where diff --git a/ghc/compiler/utils/SST.lhs b/ghc/compiler/utils/SST.lhs index 631d9c5..b3fe532 100644 --- a/ghc/compiler/utils/SST.lhs +++ b/ghc/compiler/utils/SST.lhs @@ -8,7 +8,7 @@ module SST( SST(..), SST_R, FSST(..), FSST_R, _runSST, sstToST, stToSST, - thenSST, thenSST_, returnSST, + thenSST, thenSST_, returnSST, fixSST, thenFSST, thenFSST_, returnFSST, failFSST, recoverFSST, recoverSST, fixFSST, @@ -64,6 +64,12 @@ thenSST_ m k s = case m s of { SST_R r s' -> k s' } returnSST :: r -> SST s r {-# INLINE returnSST #-} returnSST r s = SST_R r s + +fixSST :: (r -> SST s r) -> SST s r +fixSST m s = result + where + result = m loop s + SST_R loop _ = result \end{code} diff --git a/ghc/compiler/utils/Unpretty.lhs b/ghc/compiler/utils/Unpretty.lhs index 822a7a9..cf90116 100644 --- a/ghc/compiler/utils/Unpretty.lhs +++ b/ghc/compiler/utils/Unpretty.lhs @@ -10,7 +10,7 @@ module Unpretty ( Unpretty(..), uppNil, uppStr, uppPStr, uppChar, uppInt, uppInteger, - uppSP, uppLbrack, uppRbrack, uppLparen, uppRparen, + uppSP, upp'SP, uppLbrack, uppRbrack, uppLparen, uppRparen, uppSemi, uppComma, uppEquals, uppBracket, uppParens, @@ -43,7 +43,7 @@ type Unpretty = CSeq \begin{code} uppNil :: Unpretty -uppSP, uppLbrack, uppRbrack, uppLparen, uppRparen, uppSemi, uppComma, uppEquals :: Unpretty +uppSP, upp'SP, uppLbrack, uppRbrack, uppLparen, uppRparen, uppSemi, uppComma, uppEquals :: Unpretty uppStr :: [Char] -> Unpretty uppPStr :: FAST_STRING -> Unpretty @@ -92,6 +92,7 @@ uppInt n = cInt n uppInteger n = cStr (show n) uppSP = cCh ' ' +upp'SP{-'-} = cPStr SLIT(", ") uppLbrack = cCh '[' uppRbrack = cCh ']' uppLparen = cCh '(' diff --git a/ghc/compiler/utils/Util.lhs b/ghc/compiler/utils/Util.lhs index c6e92c0..b56e4cc 100644 --- a/ghc/compiler/utils/Util.lhs +++ b/ghc/compiler/utils/Util.lhs @@ -103,6 +103,8 @@ import Pretty #if __HASKELL1__ < 3 import Maybes ( Maybe(..) ) #endif + +infixr 9 `thenCmp` \end{code} %************************************************************************ @@ -144,34 +146,34 @@ are of equal length. Alastair Reid thinks this should only happen if DEBUGging on; hey, why not? \begin{code} -zipEqual :: [a] -> [b] -> [(a,b)] -zipWithEqual :: (a->b->c) -> [a]->[b]->[c] -zipWith3Equal :: (a->b->c->d) -> [a]->[b]->[c]->[d] -zipWith4Equal :: (a->b->c->d->e) -> [a]->[b]->[c]->[d]->[e] +zipEqual :: String -> [a] -> [b] -> [(a,b)] +zipWithEqual :: String -> (a->b->c) -> [a]->[b]->[c] +zipWith3Equal :: String -> (a->b->c->d) -> [a]->[b]->[c]->[d] +zipWith4Equal :: String -> (a->b->c->d->e) -> [a]->[b]->[c]->[d]->[e] #ifndef DEBUG -zipEqual = zip -zipWithEqual = zipWith -zipWith3Equal = zipWith3 -zipWith4Equal = zipWith4 +zipEqual _ = zip +zipWithEqual _ = zipWith +zipWith3Equal _ = zipWith3 +zipWith4Equal _ = zipWith4 #else -zipEqual [] [] = [] -zipEqual (a:as) (b:bs) = (a,b) : zipEqual as bs -zipEqual as bs = panic "zipEqual: unequal lists" - -zipWithEqual z (a:as) (b:bs) = z a b : zipWithEqual z as bs -zipWithEqual _ [] [] = [] -zipWithEqual _ _ _ = panic "zipWithEqual: unequal lists" - -zipWith3Equal z (a:as) (b:bs) (c:cs) - = z a b c : zipWith3Equal z as bs cs -zipWith3Equal _ [] [] [] = [] -zipWith3Equal _ _ _ _ = panic "zipWith3Equal: unequal lists" - -zipWith4Equal z (a:as) (b:bs) (c:cs) (d:ds) - = z a b c d : zipWith4Equal z as bs cs ds -zipWith4Equal _ [] [] [] [] = [] -zipWith4Equal _ _ _ _ _ = panic "zipWith4Equal: unequal lists" +zipEqual msg [] [] = [] +zipEqual msg (a:as) (b:bs) = (a,b) : zipEqual msg as bs +zipEqual msg as bs = panic ("zipEqual: unequal lists:"++msg) + +zipWithEqual msg z (a:as) (b:bs)= z a b : zipWithEqual msg z as bs +zipWithEqual msg _ [] [] = [] +zipWithEqual msg _ _ _ = panic ("zipWithEqual: unequal lists:"++msg) + +zipWith3Equal msg z (a:as) (b:bs) (c:cs) + = z a b c : zipWith3Equal msg z as bs cs +zipWith3Equal msg _ [] [] [] = [] +zipWith3Equal msg _ _ _ _ = panic ("zipWith3Equal: unequal lists:"++msg) + +zipWith4Equal msg z (a:as) (b:bs) (c:cs) (d:ds) + = z a b c d : zipWith4Equal msg z as bs cs ds +zipWith4Equal msg _ [] [] [] [] = [] +zipWith4Equal msg _ _ _ _ _ = panic ("zipWith4Equal: unequal lists:"++msg) #endif \end{code} -- 1.7.10.4