diff --git a/ghc/compiler/basicTypes/Id.lhs b/ghc/compiler/basicTypes/Id.lhs
index 152b9f3e51ece122ec6916e4717844430975927a..59d4697e5980cdd521a6e95c8bc5215fba4436c8 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 90f81a8894b34b466e412d871a0bbf32c6ee0d19..4d2a2a138c90f68bcd2da1d7ae24382bf3fb24d3 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 fcb4ecfcf021ca6b5701587c4bae8d38a04737fd..29c1667ce6228bf2f57d36f67df1701549453c7a 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 54c78983a4092f491f245e405a7aaf8803669fb0..4e2d732d58cec2f1e945073c7cb69af32889a436 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 534fa9499b76895e0e76be673b31b1a052e2bf18..b00aca77fa938b9e3cf311df6be5907c69b86891 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 1caec5f66b65a738a260ec41076984ac99e391a4..85f58f16b6a99401462d6df5bf82db68a05f3feb 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 6c378a93eea94cddbcbb4d433b94bb16f39aa1c0..0d0e620cf625e2bcde147bc2c032ef7b425d071a 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 c35219edd10084652950bde2f3277a90a72cb810..29a89a57f4c71ae8f1e2cf73dad85d6bc51e6291 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 f1a35f6ab03feaaa2fdfdc7744dc5730dc214bd7..856a119cd259e8e6d8b69fb84a68cad7b734f9b7 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 560adde93b0ae469bfe5d02ff7ccbc0cb249b6a1..8b3c23e5cc39403a50fe988c76121bca2ab133f2 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 9e08f64b13c7edc305655526afa39f77129a2463..e45fdeccf6c687718991af6ee6082c3c180c73e1 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 381c500629401be53026165ad2572ad541c45ab2..6719a8051fc5f64ab30c904857f54af669c8c852 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 e2c826997eb80f1282348993cb649d050f617743..f30e5e724edd555e451e35ae51fbccc580887031 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 39893059856b1fba1a22d2f1a847b948ffe22cf1..fe034d6bea530de4a6418750e8dd1ce1b300e1cd 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 3721baaaf9d468d0d77932c5a5ed0e4e499d5ed3..c282c70ccb23c6ecefe9668ef33a7541c8dbb4d1 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 20f0b4d1c1687b499912a118b836fe3c5444c35b..8fa61e5e7ad97760539a27934e7c0803f494a05a 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 a4d6dda09e6a887b1f38e3f957f163de88ecba03..bc5bc9ac76ba45e7061ca508ab10b6889fd4dc92 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 e76b25175704c21c0edfc0c0c11836346b47e01d..d324b5f28ea96159229c11f1a2518ca330f46214 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 9030f94c3499e8d429e418dbae5ef4d59ead484d..835c9f9d9ab3a4287814bb9074d41ce8e1794904 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 2900230d523bdee7fe34fd3f913add8b189f16dd..6236b69f4e283f9a70475e46e82869d907229b14 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 411a7c1bdb129fa3fb78d75fa3620fcc369b2a80..740044bae0402b6f2e206ae1422ae92edd1bcc6a 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 5437929a7bb0870d27d4e3e2e6a9da0c68b9cb10..ebddac241335da5a708e12b26c06aa0f20f98d3a 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 324b811fdf1508155e190579cc81d2d4737edecf..3bc2b5f9dbec58757b7c27c7d993f3a3c1414e99 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 5ad5ee52695e184fd27cdb200d518c7529f594fc..65fd71e34d59c9d39a4fd32a42fa956485bd1437 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 c5d2d29824dec7a76d7cf7fd944026ad45f78485..96d308229dc4a2a5838c90d1ee72778190a90dca 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 884ee9f8bef644e0663343f8b4647760886eae95..945ae656b8129f3b72bc7a4e58c5b8e4735305b3 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 81919132f44bfdf9e806b909d6e704be40e9d123..a2e7a00a6213b4eba352d549d49e87483a2fd386 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 e50ded59a7c0d126b172387a56a99374f41a10bb..edf7a30c8265305fff1604656993b7d756ce3742 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 796d51d0cbb89e7deeed5170d83bacb8236c004d..129afc12ef0bea28f2d0de4aded37cb22f25f2d6 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 156dab372962494dbdcac4ae2976184a0eb94b18..32159f1dc9866becc1b6c71417cc4fa3d22cc634 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 f1835a38a28e0688c4fdb73c0f1ac5eec6909535..65a5edc092115f5bb6bb9c368e9cdb50c1a37be7 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 460893aac5f86f5b3f8774809356f4eb8f108656..c6b04a279009b2c9e1aed8c419f71283f15e3fd2 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 8aac8e64ceed46cb78f957230f28ce50c94ba8e0..506b50e8d6d11ff91b17af5825cf42d42f6f0619 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 11d5e284ba88ce00d2b19e4df45f51365a57f578..1874d83a4f8f3e6c5882f723459d39d60a25cc3c 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 8d892945b3bc067be4e5904da3391f219f147df9..2efbb8494a81fa4eebb8c748e12badd5fc478d66 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
@@ -152,6 +153,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
@@ -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 4253749fe694b9397c900eb8f31ca2047b88f3a4..b5beb1f1bdaa6facc3c10e057ee31e3fadf61e3f 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 cb8be084cc94a89ff7ae49f3609a880b7073ebec..0aa0e50f522ce9cef5a9a9e0106a080629207e05 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 bae7fda7ffb6fc5bc0d345b1c97bfac2d59ee499..d87feb2ce9366fb35a02f77179aef46921c987ab 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 780017a985f28fc58df93fe2c3c8dc6f5c2f5e0b..1a969990e33a1d3ff51d088e2d32fc3face95357 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) ->
@@ -194,6 +195,27 @@ renameModule us input@(HsModule mod _ _ imports _ _ _ _ _ _ _ _ _ _)
(us2, us3) = splitUniqSupply us'
\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)
diff --git a/ghc/compiler/rename/RnExpr.lhs b/ghc/compiler/rename/RnExpr.lhs
index 5f6790e117823990b9d7eb35c5f9d698d8ed403b..d00312c42bfbeca3995a779a988e8e210859dbac 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 97445c9c62e117e60759cc99d5e47514f5283a3c..299a1f34fdf9d0182f80c9ce673e41641f91660c 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 dd1ec55c375a7d729d6085734355be0b07d012a6..cde9eef625b5c5876d9f7c6fc9db3fda973afa83 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 53d04e1d0808c7ba50704aca292685be829a31bc..0f7037269dd1c1b7ffd5e050f3ce977ca432e677 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 0291b37207b6be7e7580a72071e7307b914352c4..6050153baca5d0b496d1431156f46ad622331157 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 f27614cb5b130b01c17b87b8fc76a9cfef4231c3..ba38151367cedc805cc3d4e8fdad79b81971fc6f 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 43a56463da21f8abd46d1901bd089246ed5b0649..136c4bfeb1862b21e7c57c6433755cb5538d3bb1 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 a49aadb682039556fce34d9e33f6527ceb07e2d6..b09986e370058266cfb969641d5c87d2c1123080 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 a456fde4e1c146e7d79067dcd2605b2f958eec80..55a0e318141f4edf5ce1c7d2c52b5d271a4873ab 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 47d0a27cf497bb301a1c071dc2098aa5f6d96ea9..ad986d78b6dd20f7296bbfa1bb7e3e0b096f9829 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 c6567dae65b01fe67b76d0b86c5956c5ea8793eb..cc7d4fbdb8b2fcbd367770603b76aace46693dbe 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 062dada607ebcff56acd2a7a46258e59c4c9befc..72c67099fca1f71a8140ccc4269a1b85b7f49c9f 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 eb0b36d1021b1e3e42672cf024ea12799c80256b..627ade946111c2190d17f9853624309aef5680d2 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 7427ad4c2ca390c8d1625744de13bd0c39e6f6fe..d1b50a5f837c9b8fdf1cae1ccb4bde6561362f8b 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 a539af9e42c43716ee79d54cb93ce20653aaa4e7..3ec493a76a2cf3ad0059a4f03a996cb643cc695b 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 ba098eab38f6ec900302a95855d6a36d3e4ee723..ade1cfa03fafb9e365f7db65492ce5d58d18563f 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 1569843dd8a2317dc94e0950c48ccccc0dc38586..4855ede6685d29d7ba37ab2628ca0fa12b1fdf56 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 f046fa845a38b47c89b4d5a9bfb664ef8234bc9e..ba1cc4e7bc3849fa61e16e16b5704173fa7da262 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 44319c7c2c1acaae9c06c0e2dd00e0270a1807fb..f6eecf2b3197a1db369eaea4c79b157c99adfcba 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 b9aa02978f19a9313b6c4b6e111a8940b9d56a69..9ef9b2a491c89574d898a9b27fc0b4d8697bade1 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 b1c83ddba6c4d70b67d4abf1e978b53da82334d1..0562a29846359d299465390fda82a73c53c213ff 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 c8d2144c83c0b7fee38c8bbf35a5a3b7ff0e25ed..eab32d0016e8a996ea484ae56bb859c799dda59c 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 57fff4d56c9b878fbc815cc861088e3311d13966..dd6379c2be8c782c293f88c80702cdd17d101889 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 5f6092c0318e75949ee105c1d64c83135b58dcf8..e0f4adf6b32f2af5ac9fbfdb60c15905b3ef6ea4 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 990e8b2035aa3325dfaf8051468d8d863b64d860..7af0cc7eb7e461d1f54f6a1b2df23b99e08ccb85 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 d65eb8745f00636ebe1f55d4433d8aba029c62f9..4a87887eb0d4ce35b8ef6f3c5e476116c86bb228 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 233cca7020478a75a2becc1e9148de6281db2536..3ed0d380905764fd2e22bd6da56d028db77fa8aa 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 8c7c7dbe7c9370109b43ccc5cc35195b165b1bfb..48263f514276063b538d84102063e2bbccf78cdd 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 60c943ecb593ec12f1857a87a5bc5055aea7202e..cc26fab49085979a8f98031573aee5c14cc58d64 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 3eb079baf2ec97e378706de3b893342cb3b5aab2..71c6e90388eede4e59c1fa620ef244fec1bb09fd 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 a7dd9e3eba4bfe83b926c2081f2b80ab5d7ca27e..ceea5e7242b5941e156408ff998c0c2cbc51fa0c 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 7a0fbb10e434b7c83094cc592936b76da2c44874..079c2920b88f600ac8cb8846629a94bdd5305ba6 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 a24e7acd1a9b1229d33f55c87e03ca8704e153ba..b4fc7f2c8046f07d0cf4cbf58d6655613a9b9359 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 21be1952404f962432c11221cfaf10481fe35cfd..b4d87a7b904e0748bb73ce52ecdcf8cacdfbbe7d 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 a4c43af3dff53a0007051bd2e59bd8bd137fb711..d2a63baf2f77053c2120339f6c9ea1a4b404c8c8 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 0296080e8aa8679c9d627b6677be4303c4f74213..d714ddd21ac0bb1cd0a9009565ea2aadc68b0a16 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 778a28a6a079e97649dfd61bc710d69a88d053dd..5e7d91e4ca92e8c55e30b41dd0cd57468df017ae 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 ba1bcbf3a3da263185b34eaa4db6cd0023c8dcdb..7702e31d652ec61e903d4366a71c73c1f4bf8006 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 c5d9e36c24012b900af6bd1f236a24f98468037e..594653b355cc5eb931fae63070a4c5ef1e0582ab 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 e631dc1f8d1d4fae999822a337b411829f87005e..cf7eb327458afd340eddead289ab03b52553e06b 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 3c86baf7eb4dd6d444395d4795c3cf4eab7e50db..ba69475148746d05e5a9eff16c62afae0896fe55 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 238e3fd58a17971cb499d6f67f5d8fab4149361f..0f1a61a8edfe56bfb5af507aabde02d438c9778a 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 c8180abecaa6678745bc6477cef3fe55a9775283..b41b4ea943956c0d29be82802c8dcc957b6a6690 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 3026867af98f622a3b6606b81496a9c711f20c40..5e7becfa5c9e1df4aad257b921f668c21fc9b874 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 f279531d5cf2ba84f22ef162fabe848fa4fe9428..9f3506bdeb8931e6c35f7ef9c7ffdaf00625cce0 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 9be9ddeee7d049913a063135f3165bff0fd7be18..876564daad2815624243c9b4dd464db53384e358 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 40df4a814aafe7df51928ff5048de08bb7744786..8e28da609999fd0e991a3f3294c7500c673cacda 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 bcb90dd97cf1443b565638b3cdf5cc78732dd34c..fcde43dc7fbb00f679d0938f74c80c25162fdfc4 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,11 +475,88 @@ 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 fce676f4494037649725541c463c7e171855ed4d..495c0a5fec822b4815fe16d118380cdb4b6ec736 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 b117f2fa94c6f025fa26e28803fa08723dcdc69d..e248b90d0eb9f82d5ac21788adc7c701ec43774c 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 44fc091184d8a86eb87e1222e98065ed21141d98..0a602c731c66b33c9fbbe90d5766530d6830ec72 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 11d0545e669fcfe1fcd1a9b1cbab985ffc87e26a..39c27f32396d3c05ea191c6ed47e22e0ae0e101a 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 e5db71fc2ff82e31d727b4105804165faf7e1915..0cf92a5ad8e7e9b4d51c2374002a0e876c845078 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 ad6875d494a9ced34aab92e061022ebf07fde90f..249ad6c76bec9393468a2c51861402f599147357 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 c066295e093af062e82cd57eb423994da26c9bf7..472060547cef8ac92149bde26711238ec5c97544 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 c975f35aeda65013729a6fb29f8137f114eabe58..d40619627a2185374231223d0f56075c1e4ccdb8 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 cddcdcb33902a08ae295eb3cf0ab49c26eab939f..88f1e855d8c6d0d074cf3d9b7e813d8e65ff446e 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 5c06b0f615a2101c32f6399ea7a3d9e99053421f..e7774150be31c65185b3f4e79934a8d9d8ba36d0 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 31bad8120608818d25b31c4c9cf24167d5cf7ba4..e5c20cc17503031f849d51196b46f22523d851f2 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 631d9c53b796d7427ae0cf76eaa94845a489dfec..b3fe5327549cbe7fcc5913841e905bd004ec3b02 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 822a7a900d11b301471c945038da2b822b53f0d2..cf90116dc8cf7f25ec1975c6dcad71598c45a6d2 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 c6e92c0740d97d4cc3e861f7c4b404e5d222cd8c..b56e4cca0f7a5641cad86ff1b6fc929bd0952368 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}