[project @ 1996-01-08 20:28:12 by partain]

Initial revision

16 files changed, 1733 insertions, 0 deletions

diff --git a/ghc/compiler/envs/CE.hi b/ghc/compiler/envs/CE.hi
new file mode 100644
index 0000000000..1a2001ac97
--- /dev/null
+++ b/ghc/compiler/envs/CE.hi
@@ -0,0 +1,51 @@
+{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
+interface CE where
+import CharSeq(CSeq)
+import Class(Class, ClassOp)
+import CmdLineOpts(GlobalSwitch)
+import ErrUtils(Error(..))
+import Id(Id)
+import InstEnv(InstTemplate)
+import Maybes(MaybeErr)
+import Name(Name)
+import NameTypes(FullName, ShortName)
+import PreludePS(_PackedString)
+import Pretty(Delay, PprStyle, Pretty(..), PrettyRep)
+import TyCon(TyCon)
+import TyVar(TyVarTemplate)
+import UniType(UniType)
+import UniqFM(UniqFM, eltsUFM, emptyUFM, plusUFM, singletonDirectlyUFM)
+import Unique(Unique, u2i)
+type CE = UniqFM Class
+data Class 	{-# GHC_PRAGMA MkClass Unique FullName TyVarTemplate [Class] [Id] [ClassOp] [Id] [Id] [(UniType, InstTemplate)] [(Class, [Class])] #-}
+type Error = PprStyle -> Int -> Bool -> PrettyRep
+data MaybeErr a b 	{-# GHC_PRAGMA Succeeded a | Failed b #-}
+data Name 	{-# GHC_PRAGMA Short Unique ShortName | WiredInTyCon TyCon | WiredInVal Id | PreludeVal Unique FullName | PreludeTyCon Unique FullName Int Bool | PreludeClass Unique FullName | OtherTyCon Unique FullName Int Bool [Name] | OtherClass Unique FullName [Name] | OtherTopId Unique FullName | ClassOpName Unique Name _PackedString Int | Unbound _PackedString #-}
+data PprStyle 	{-# GHC_PRAGMA PprForUser | PprDebug | PprShowAll | PprInterface (GlobalSwitch -> Bool) | PprForC (GlobalSwitch -> Bool) | PprUnfolding (GlobalSwitch -> Bool) | PprForAsm (GlobalSwitch -> Bool) Bool ([Char] -> [Char]) #-}
+type Pretty = Int -> Bool -> PrettyRep
+data PrettyRep 	{-# GHC_PRAGMA MkPrettyRep CSeq (Delay Int) Bool Bool #-}
+data UniqFM a 	{-# GHC_PRAGMA EmptyUFM | LeafUFM Int# a | NodeUFM Int# Int# (UniqFM a) (UniqFM a) #-}
+data Unique 	{-# GHC_PRAGMA MkUnique Int# #-}
+checkClassCycles :: UniqFM Class -> MaybeErr () (PprStyle -> Int -> Bool -> PrettyRep)
+	{-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-}
+eltsUFM :: UniqFM a -> [a]
+	{-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-}
+emptyUFM :: UniqFM a
+	{-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 1 0 X 1 _/\_ u0 -> _!_ _ORIG_ UniqFM EmptyUFM [u0] [] _N_ #-}
+lookupCE :: UniqFM Class -> Name -> Class
+	{-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ #-}
+nullCE :: UniqFM Class
+	{-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _!_ _ORIG_ UniqFM EmptyUFM [Class] [] _N_ #-}
+plusCE :: UniqFM Class -> UniqFM Class -> UniqFM Class
+	{-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _TYAPP_  _ORIG_ UniqFM plusUFM { Class } _N_ #-}
+plusUFM :: UniqFM a -> UniqFM a -> UniqFM a
+	{-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ #-}
+rngCE :: UniqFM Class -> [Class]
+	{-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _TYAPP_  _ORIG_ UniqFM eltsUFM { Class } _N_ #-}
+singletonDirectlyUFM :: Unique -> a -> UniqFM a
+	{-# GHC_PRAGMA _A_ 2 _U_ 12 _N_ _S_ "U(P)L" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: Int#) (u2 :: u0) -> _!_ _ORIG_ UniqFM LeafUFM [u0] [u1, u2] _N_} _F_ _IF_ARGS_ 1 2 CX 4 _/\_ u0 -> \ (u1 :: Unique) (u2 :: u0) -> case u1 of { _ALG_ _ORIG_ Unique MkUnique (u3 :: Int#) -> _!_ _ORIG_ UniqFM LeafUFM [u0] [u3, u2]; _NO_DEFLT_ } _N_ #-}
+u2i :: Unique -> Int#
+	{-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(P)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: Int#) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: Unique) -> case u0 of { _ALG_ _ORIG_ Unique MkUnique (u1 :: Int#) -> u1; _NO_DEFLT_ } _N_ #-}
+unitCE :: Unique -> Class -> UniqFM Class
+	{-# GHC_PRAGMA _A_ 2 _U_ 12 _N_ _S_ "U(P)L" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 3 \ (u0 :: Int#) (u1 :: Class) -> _!_ _ORIG_ UniqFM LeafUFM [Class] [u0, u1] _N_} _F_ _IF_ARGS_ 0 2 CX 4 \ (u0 :: Unique) (u1 :: Class) -> case u0 of { _ALG_ _ORIG_ Unique MkUnique (u2 :: Int#) -> _!_ _ORIG_ UniqFM LeafUFM [Class] [u2, u1]; _NO_DEFLT_ } _N_ #-}
+
diff --git a/ghc/compiler/envs/CE.lhs b/ghc/compiler/envs/CE.lhs
new file mode 100644
index 0000000000..d1e4ea73ea
--- /dev/null
+++ b/ghc/compiler/envs/CE.lhs
@@ -0,0 +1,90 @@
+%
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1994
+%
+\section[CE]{Class environment}
+
+\begin{code}
+#include "HsVersions.h"
+
+module CE (
+	CE(..),
+	nullCE, unitCE, rngCE,
+	plusCE, lookupCE,
+	checkClassCycles,
+
+	-- imported things so we're self-contained...
+	Unique, UniqFM,
+	Class, MaybeErr, Name, Pretty(..), PprStyle,
+	PrettyRep, Error(..)
+	
+	IF_ATTACK_PRAGMAS(COMMA emptyUFM COMMA plusUFM)
+	IF_ATTACK_PRAGMAS(COMMA eltsUFM  COMMA singletonDirectlyUFM)
+	IF_ATTACK_PRAGMAS(COMMA u2i)
+    ) where
+
+import AbsUniType	( getClassSig, Class, ClassOp, TyCon, FullName, Arity(..)
+			  IF_ATTACK_PRAGMAS(COMMA cmpTyCon COMMA cmpClass)
+			)
+import Digraph		( topologicalSort )
+import Errors		-- notably classCycleErr
+import UniqFM		-- basic environment handling
+import Maybes		( Maybe(..), MaybeErr(..) )
+import Name		-- Name(..), etc.
+import Pretty
+import Outputable	-- def of ppr
+import Unique		-- for ClassKey uniques
+import Util
+\end{code}
+
+%************************************************************************
+%*									*
+%*		The main representation					*
+%*									*
+%************************************************************************
+
+\begin{code}
+--data CE = MkCE (FiniteMap Unique Class) -- keyed off Class's Uniques
+type CE = UniqFM Class
+#define MkCE {--}
+-- also killed instance CE, exported non-abstractly
+
+nullCE :: CE
+nullCE = MkCE emptyUFM
+
+rngCE :: CE -> [Class]
+rngCE (MkCE env) = eltsUFM env
+
+unitCE :: Unique{-ClassKey-} -> Class -> CE
+unitCE u c = MkCE (singletonDirectlyUFM u c)
+
+plusCE :: CE -> CE -> CE
+plusCE (MkCE ce1) (MkCE ce2) = MkCE (plusUFM ce1 ce2)
+
+lookupCE :: CE -> Name -> Class
+lookupCE (MkCE ce) name
+  = case name of
+      PreludeClass key _  -> case (lookupDirectlyUFM ce key) of
+				Just clas -> clas
+				Nothing	-> err_msg
+      OtherClass uniq _	_ -> case (lookupDirectlyUFM ce uniq) of
+				Just clas -> clas
+				Nothing	-> panic "lookupCE! (non-prelude)"
+  where
+    err_msg = error ("ERROR: in looking up a Prelude class! "++(ppShow 80 (ppr PprDebug name))++"\n(This can happen if you use `-fno-implicit-prelude'\nor you hide the system's Prelude.hi in some way.)\n")
+
+checkClassCycles :: CE -> MaybeErr () Error
+checkClassCycles (MkCE stuff)
+  = case (topologicalSort (==) edges classes) of
+      Succeeded _ -> Succeeded ()
+      Failed cycles
+	   -> Failed (classCycleErr [ map fmt_tycon c | c <- cycles ])
+		where
+		  fmt_tycon c = (ppr PprForUser c, getSrcLoc c)
+  where
+    classes = eltsUFM stuff	-- the "vertices"
+    edges   = concat (map get_edges classes)
+
+    get_edges clas
+      = let  (_, super_classes, _) = getClassSig clas  in
+	[ (clas, super_class) | super_class <- super_classes ]
+\end{code}
diff --git a/ghc/compiler/envs/E.hi b/ghc/compiler/envs/E.hi
new file mode 100644
index 0000000000..983265bb26
--- /dev/null
+++ b/ghc/compiler/envs/E.hi
@@ -0,0 +1,65 @@
+{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
+interface E where
+import CE(CE(..))
+import Class(Class)
+import Id(Id, IdDetails)
+import IdInfo(IdInfo)
+import Maybes(Labda)
+import Name(Name)
+import NameTypes(FullName, ShortName)
+import PreludePS(_PackedString)
+import TCE(TCE(..))
+import TyCon(TyCon)
+import TyVar(TyVar)
+import UniType(UniType)
+import UniqFM(UniqFM)
+import Unique(Unique)
+type CE = UniqFM Class
+data E 	{-# GHC_PRAGMA MkE (UniqFM TyCon) (UniqFM Id) (UniqFM Id) (UniqFM Class) #-}
+type GVE = [(Name, Id)]
+data Id 	{-# GHC_PRAGMA Id Unique UniType IdInfo IdDetails #-}
+type LVE = [(Name, Id)]
+data Labda a 	{-# GHC_PRAGMA Hamna | Ni a #-}
+data Name 	{-# GHC_PRAGMA Short Unique ShortName | WiredInTyCon TyCon | WiredInVal Id | PreludeVal Unique FullName | PreludeTyCon Unique FullName Int Bool | PreludeClass Unique FullName | OtherTyCon Unique FullName Int Bool [Name] | OtherClass Unique FullName [Name] | OtherTopId Unique FullName | ClassOpName Unique Name _PackedString Int | Unbound _PackedString #-}
+type TCE = UniqFM TyCon
+data TyVar 	{-# GHC_PRAGMA PrimSysTyVar Unique | PolySysTyVar Unique | OpenSysTyVar Unique | UserTyVar Unique ShortName #-}
+data UniqFM a 	{-# GHC_PRAGMA EmptyUFM | LeafUFM Int# a | NodeUFM Int# Int# (UniqFM a) (UniqFM a) #-}
+getE_CE :: E -> UniqFM Class
+	{-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(AAAS)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: UniqFM Class) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: E) -> case u0 of { _ALG_ _ORIG_ E MkE (u1 :: UniqFM TyCon) (u2 :: UniqFM Id) (u3 :: UniqFM Id) (u4 :: UniqFM Class) -> u4; _NO_DEFLT_ } _N_ #-}
+getE_GlobalVals :: E -> [Id]
+	{-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(ASLA)" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_ #-}
+getE_TCE :: E -> UniqFM TyCon
+	{-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(SAAA)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: UniqFM TyCon) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: E) -> case u0 of { _ALG_ _ORIG_ E MkE (u1 :: UniqFM TyCon) (u2 :: UniqFM Id) (u3 :: UniqFM Id) (u4 :: UniqFM Class) -> u1; _NO_DEFLT_ } _N_ #-}
+growE_LVE :: E -> [(Name, Id)] -> E
+	{-# GHC_PRAGMA _A_ 2 _U_ 11 _N_ _S_ "U(LLLL)L" {_A_ 5 _U_ 22221 _N_ _N_ _N_ _N_} _N_ _N_ #-}
+lookupE_Binder :: E -> Name -> Id
+	{-# GHC_PRAGMA _A_ 2 _U_ 12 _N_ _S_ "U(AASA)S" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_ #-}
+lookupE_ClassOpByKey :: E -> Unique -> _PackedString -> Id
+	{-# GHC_PRAGMA _A_ 3 _U_ 122 _N_ _S_ "U(AAAS)LL" {_A_ 3 _U_ 222 _N_ _N_ _N_ _N_} _N_ _N_ #-}
+lookupE_Value :: E -> Name -> Id
+	{-# GHC_PRAGMA _A_ 2 _U_ 12 _N_ _S_ "U(ALLA)S" {_A_ 3 _U_ 222 _N_ _N_ _N_ _N_} _N_ _N_ #-}
+lookupE_ValueQuietly :: E -> Name -> Labda Id
+	{-# GHC_PRAGMA _A_ 2 _U_ 12 _N_ _S_ "U(ALLA)S" {_A_ 3 _U_ 222 _N_ _N_ _N_ _N_} _N_ _N_ #-}
+mkE :: UniqFM TyCon -> UniqFM Class -> E
+	{-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _N_ _N_ _N_ #-}
+nullE :: E
+	{-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
+nullGVE :: [(Name, Id)]
+	{-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _!_ _NIL_ [(Name, Id)] [] _N_ #-}
+nullLVE :: [(Name, Id)]
+	{-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _!_ _NIL_ [(Name, Id)] [] _N_ #-}
+plusE_CE :: E -> UniqFM Class -> E
+	{-# GHC_PRAGMA _A_ 2 _U_ 12 _N_ _S_ "U(LLLL)L" {_A_ 5 _U_ 22222 _N_ _N_ _N_ _N_} _N_ _N_ #-}
+plusE_GVE :: E -> [(Name, Id)] -> E
+	{-# GHC_PRAGMA _A_ 2 _U_ 11 _N_ _S_ "U(LLLL)L" {_A_ 5 _U_ 22221 _N_ _N_ _N_ _N_} _N_ _N_ #-}
+plusE_TCE :: E -> UniqFM TyCon -> E
+	{-# GHC_PRAGMA _A_ 2 _U_ 12 _N_ _S_ "U(LLLL)L" {_A_ 5 _U_ 22222 _N_ _N_ _N_ _N_} _N_ _N_ #-}
+plusGVE :: [a] -> [a] -> [a]
+	{-# GHC_PRAGMA _A_ 2 _U_ 12 _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _ORIG_ PreludeList (++) _N_ #-}
+plusLVE :: [a] -> [a] -> [a]
+	{-# GHC_PRAGMA _A_ 2 _U_ 12 _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _ORIG_ PreludeList (++) _N_ #-}
+tvOfE :: E -> [TyVar]
+	{-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(AASA)" {_A_ 1 _U_ 2 _N_ _N_ _N_ _N_} _N_ _N_ #-}
+unitGVE :: Name -> Id -> [(Name, Id)]
+	{-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _N_ _N_ _N_ #-}
+
diff --git a/ghc/compiler/envs/E.lhs b/ghc/compiler/envs/E.lhs
new file mode 100644
index 0000000000..c0c8b0f764
--- /dev/null
+++ b/ghc/compiler/envs/E.lhs
@@ -0,0 +1,268 @@
+%
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
+%
+\section[E]{Main typechecker environment}
+
+\begin{code}
+#include "HsVersions.h"
+
+module E (
+	E,
+	mkE, nullE,
+	getE_GlobalVals, getE_TCE, getE_CE,
+	plusE_TCE, plusE_CE,
+
+	growE_LVE, plusE_GVE, tvOfE,
+
+	lookupE_Value, lookupE_ValueQuietly,
+	lookupE_ClassOpByKey, lookupE_Binder,
+
+	GVE(..), LVE(..),
+	plusLVE, nullLVE,
+	plusGVE, nullGVE, unitGVE, -- UNUSED: rngGVE,
+
+	-- and to make the interface self-sufficient...
+	CE(..), Id, Name, TCE(..), TyVar, Maybe, UniqFM
+    ) where
+
+import CE
+import TCE
+import UniqFM		-- basic env handling code
+
+import AbsPrel		( PrimOp
+			  IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp)
+			  IF_ATTACK_PRAGMAS(COMMA pprPrimOp)
+			)
+import AbsUniType	( getClassOps, extractTyVarsFromTy,
+			  getClassBigSig, getClassOpString, TyVar,
+			  TyVarTemplate, ClassOp, Class, Arity(..),
+			  TauType(..)
+			  IF_ATTACK_PRAGMAS(COMMA cmpTyVar COMMA cmpClass)
+			)
+import Id		( getIdUniType, Id, IdInfo )
+import Maybes		( MaybeErr(..), Maybe(..) )
+import Name		-- Name(..), etc.
+import Outputable	-- def of ppr, etc.
+import Pretty		-- to pretty-print error messages
+import UniqSet		-- this use of Sets is a HACK (WDP 94/05)
+import Unique		-- *Key stuff
+import Util
+\end{code}
+
+
+%************************************************************************
+%*									*
+\subsection{Type declarations}
+%*									*
+%************************************************************************
+
+
+\begin{code}
+data E
+  = MkE	TCE 	    -- type environment                                        
+	GVB	    -- "global" value bindings; no free type vars
+	LVB	    -- "local" value bindings; may have free type vars      
+	CE 	    -- class environment                                       
+
+mkE :: TCE -> CE -> E
+mkE tce ce = MkE tce nullGVB nullLVB ce
+
+nullE :: E
+nullE = MkE nullTCE nullGVB nullLVB nullCE
+\end{code}
+
+The ``local'' and ``global'' bindings, @LVB@ and @GVB@, are
+non-exported synonyms.  The important thing is that @GVB@ doesn't
+contain any free type variables.  This is used (only) in @tvOfE@,
+which extracts free type variables from the environment.  It's quite a
+help to have this separation because there may be quite a large bunch
+of imported things in the @GVB@, all of which are guaranteed
+polymorphic.
+
+\begin{code}
+type LVB = UniqFM Id -- Locals just have a Unique
+type GVB = UniqFM Id -- Globals might be a prelude thing; hence IdKey
+
+nullLVB = (emptyUFM :: LVB)
+nullGVB = (emptyUFM :: GVB)
+\end{code}
+
+The ``local'' and ``global'' value environments are not part of @E@ at
+all, but is used to provide increments to the value bindings.  GVE are
+carries the implication that there are no free type variables.
+
+\begin{code}
+type LVE = [(Name, Id)]	-- Maps Names to Ids
+type GVE = [(Name, Id)]	-- Maps Names to Ids
+
+nullLVE     = ([] :: LVE)
+plusLVE a b = a ++ b
+nullGVE     = ([] :: GVE)
+unitGVE n i = ( [(n, i)] :: GVE )
+-- UNUSED: rngGVE  gve = map snd gve
+plusGVE a b = a ++ b
+\end{code}
+
+%************************************************************************
+%*									*
+\subsection{Value environment stuff}
+%*									*
+%************************************************************************
+
+Looking up things should mostly succeed, because the renamer should
+have spotted all out-of-scope names.  The exception is instances.
+
+The ``Quietly'' version is for pragmas, where lookups very well may
+fail. @lookup_val@ is the internal function that does the work.
+
+\begin{code}
+lookupE_Value	     :: E -> Name -> Id
+lookupE_ValueQuietly :: E -> Name -> Maybe Id
+
+lookupE_Value e nm
+  = case lookup_val e nm of
+      Succeeded id -> id
+      Failed (should_panic, msg)
+	-> if should_panic then panic msg else error msg
+
+lookupE_ValueQuietly e nm
+  = case lookup_val e nm of
+      Succeeded id -> Just id
+      Failed _	   -> Nothing
+\end{code}
+
+\begin{code}
+lookup_val (MkE _ gvb lvb ce) name
+  = case name of
+
+      WiredInVal id   -> Succeeded id
+      PreludeVal key _ -> case (lookupDirectlyUFM gvb key) of
+			    Just id -> Succeeded id
+			    Nothing -> Failed (False, prelude_err_msg)
+
+      ClassOpName uniq clas_name _ tag -> id_from_env uniq
+
+      -- You might think that top-level ids are guaranteed to have no
+      -- free tyvars, so look only in gvb; but you'd be wrong!  When
+      -- type-checking the RHS of recursive top-level defns, the name
+      -- of the thing is bound to a *monomorphic* type, which is later
+      -- generalised.  So we have to look in the LVE too.
+
+      OtherTopId uniq _ -> id_from_env uniq
+
+      -- Short names could be in either GVB or LVB
+      Short uniq _      -> id_from_env uniq
+
+      funny_name -> pprPanic "lookup_val: funny Name" (ppr PprDebug funny_name)
+  where
+    prelude_err_msg = "ERROR: in looking up a built-in Prelude value!\n(This can happen if you use `-fno-implicit-prelude'\nor you hide the system's Prelude.hi in some way.)"
+
+    id_from_env uniq
+      = case (lookupDirectlyUFM lvb uniq) of
+	  Just id -> Succeeded id
+	  Nothing ->
+	    case (lookupDirectlyUFM gvb uniq) of
+	      Just id -> Succeeded id
+	      Nothing -> Failed (True, -- should panic
+			  ("lookupE_Value: unbound name: "++(ppShow 80 (ppr PprShowAll name))))
+\end{code}
+
+For Prelude things that we reach out and grab, we have only an @Unique@.
+\begin{code}
+lookupE_ClassOpByKey :: E -> Unique{-ClassKey-} -> FAST_STRING -> Id
+
+lookupE_ClassOpByKey (MkE _ gvb lvb ce) clas_key op_str
+  = let
+	clas   = lookupCE ce (PreludeClass clas_key bottom)
+	bottom = pprPanic ("lookupE_ClassOpByKey: "++(_UNPK_ op_str))
+			  (ppAbove (pprUnique clas_key) (ppr PprShowAll (rngCE ce)))
+
+	(clas_tyvar_tmpl, scs, sc_sel_ids, ops, op_sel_ids, defm_ids)
+	  = getClassBigSig clas
+    in
+    case [ op_sel_id | (op, op_sel_id) <- ops `zip` op_sel_ids,
+		       op_str == getClassOpString op ] of
+      [op] -> op
+    -- Seems a rather horrible way to do it (ToDo)
+\end{code}
+
+@lookupE_Binder@ is like @lookupE_Value@, but it is used for {\em
+binding} occurrences of a variable, rather than {\em uses}.  The
+difference is that there should always be an entry in the LVE for
+binding occurrences.  Just a sanity check now, really.
+
+\begin{code}
+lookupE_Binder :: E -> Name -> Id
+lookupE_Binder (MkE _ _ lvb _) name
+  = case (lookupDirectlyUFM lvb (name2uniq name)) of
+      Just id -> id
+      Nothing -> pprPanic "lookupE_Binder: unbound name: " (ppr PprShowAll name)
+\end{code}
+
+\begin{code}
+getE_GlobalVals :: E -> [Id]
+getE_GlobalVals  (MkE tce gvb lvb ce)
+  = let
+    	result = eltsUFM gvb ++ eltsUFM lvb
+    in
+    -- pprTrace "Global Ids:" (ppr PprShowAll result)
+    result
+
+plusE_GVE :: E -> GVE -> E
+plusE_GVE (MkE tce gvb lvb ce) gve
+  = let
+	new_stuff = listToUFM_Directly [(name2idkey n, i) | (n,i) <- gve ]
+    in
+    MkE tce (plusUFM gvb new_stuff) lvb ce
+  where
+    name2idkey (PreludeVal k _) = k
+    name2idkey (OtherTopId u _) = u
+    name2idkey (ClassOpName u _ _ _) = u
+
+growE_LVE :: E -> LVE -> E
+growE_LVE (MkE tce gvb lvb ce) lve
+  = let
+	new_stuff = listToUFM_Directly [(name2uniq n, i) | (n,i) <- lve ]
+    in
+    MkE tce gvb (plusUFM lvb new_stuff) ce
+
+-- ToDo: move this elsewhere??
+name2uniq (Short u _)   	= u
+name2uniq (OtherTopId u _)	= u
+name2uniq (ClassOpName u _ _ _) = panic "growE_LVE:name2uniq"
+\end{code}
+
+Return the free type variables of an LVE; there are no duplicates in
+the result---hence all the @Set@ bozo-ery.  The free tyvars can only
+occur in the LVB part.
+
+\begin{code}
+tvOfE :: E -> [TyVar]
+tvOfE (MkE tce gvb lvb ce) 
+  = uniqSetToList (mkUniqSet (
+	foldr ((++) . extractTyVarsFromTy . getIdUniType) [] (eltsUFM lvb)
+    ))
+\end{code}
+
+%************************************************************************
+%*									*
+%*	
+\subsection{Type and class environments}
+%*									*
+%************************************************************************
+
+\begin{code}
+getE_TCE :: E -> TCE
+getE_TCE (MkE tce gvb lvb ce) = tce
+
+getE_CE :: E -> CE
+getE_CE  (MkE tce gvb lvb ce) = ce
+
+plusE_TCE :: E -> TCE -> E
+plusE_TCE (MkE tce gvb lvb ce) tce'
+  = MkE (plusTCE tce' tce) gvb lvb ce
+
+plusE_CE :: E -> CE -> E
+plusE_CE (MkE tce gvb lvb ce) ce'
+  = MkE tce gvb lvb (plusCE ce ce')
+\end{code}
diff --git a/ghc/compiler/envs/IdEnv.hi b/ghc/compiler/envs/IdEnv.hi
new file mode 100644
index 0000000000..4760b953c0
--- /dev/null
+++ b/ghc/compiler/envs/IdEnv.hi
@@ -0,0 +1,73 @@
+{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
+interface IdEnv where
+import Id(Id, IdDetails)
+import IdInfo(IdInfo)
+import Maybes(Labda(..))
+import Outputable(NamedThing)
+import UniType(UniType)
+import UniqFM(UniqFM, addToUFM, delFromUFM, delListFromUFM, eltsUFM, emptyUFM, filterUFM, listToUFM, lookupUFM, mapUFM, minusUFM, plusUFM, plusUFM_C, singletonUFM)
+import Unique(Unique, u2i)
+data Id 	{-# GHC_PRAGMA Id Unique UniType IdInfo IdDetails #-}
+type IdEnv a = UniqFM a
+data Labda a   = Hamna | Ni a
+data UniqFM a 	{-# GHC_PRAGMA EmptyUFM | LeafUFM Int# a | NodeUFM Int# Int# (UniqFM a) (UniqFM a) #-}
+data Unique 	{-# GHC_PRAGMA MkUnique Int# #-}
+addOneToIdEnv :: UniqFM a -> Id -> a -> UniqFM a
+	{-# GHC_PRAGMA _A_ 3 _U_ 212 _N_ _S_ "SU(U(P)AAA)L" {_A_ 3 _U_ 222 _N_ _N_ _N_ _N_} _N_ _N_ #-}
+addToUFM :: NamedThing a => UniqFM b -> a -> b -> UniqFM b
+	{-# GHC_PRAGMA _A_ 4 _U_ 1222 _N_ _S_ "U(AAAAAASAAA)SLL" {_A_ 4 _U_ 1222 _N_ _N_ _N_ _N_} _N_ _SPECIALISE_ [ Name, _N_ ] 1 { _A_ 3 _U_ 222 _N_ _S_ "SSL" _N_ _N_ }, [ TyVar, _N_ ] 1 { _A_ 3 _U_ 222 _N_ _S_ "SSL" _N_ _N_ }, [ Id, _N_ ] 1 { _A_ 3 _U_ 212 _N_ _S_ "SU(U(P)AAA)L" {_A_ 3 _U_ 222 _N_ _N_ _N_ _N_} _N_ _N_ } #-}
+combineIdEnvs :: (a -> a -> a) -> UniqFM a -> UniqFM a -> UniqFM a
+	{-# GHC_PRAGMA _A_ 3 _U_ 222 _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _ORIG_ UniqFM plusUFM_C _N_ #-}
+delFromUFM :: NamedThing a => UniqFM b -> a -> UniqFM b
+	{-# GHC_PRAGMA _A_ 3 _U_ 122 _N_ _S_ "U(AAAAAASAAA)SL" {_A_ 3 _U_ 122 _N_ _N_ _N_ _N_} _N_ _SPECIALISE_ [ Name, _N_ ] 1 { _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ }, [ TyVar, _N_ ] 1 { _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ }, [ Id, _N_ ] 1 { _A_ 2 _U_ 21 _N_ _S_ "SU(U(P)AAA)" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_ } #-}
+delListFromUFM :: NamedThing a => UniqFM b -> [a] -> UniqFM b
+	{-# GHC_PRAGMA _A_ 3 _U_ 221 _N_ _N_ _N_ _SPECIALISE_ [ Name, _N_ ] 1 { _A_ 2 _U_ 21 _N_ _S_ "LS" _N_ _N_ }, [ TyVar, _N_ ] 1 { _A_ 2 _U_ 21 _N_ _S_ "LS" _N_ _N_ }, [ Id, _N_ ] 1 { _A_ 2 _U_ 21 _N_ _S_ "LS" _N_ _N_ } #-}
+delManyFromIdEnv :: UniqFM a -> [Id] -> UniqFM a
+	{-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _SPEC_ _ORIG_ UniqFM delListFromUFM [ (Id), _N_ ] _N_ #-}
+delOneFromIdEnv :: UniqFM a -> Id -> UniqFM a
+	{-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _S_ "SU(U(P)AAA)" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_ #-}
+eltsUFM :: UniqFM a -> [a]
+	{-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-}
+emptyUFM :: UniqFM a
+	{-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 1 0 X 1 _/\_ u0 -> _!_ _ORIG_ UniqFM EmptyUFM [u0] [] _N_ #-}
+filterUFM :: (a -> Bool) -> UniqFM a -> UniqFM a
+	{-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "LS" _N_ _N_ #-}
+growIdEnv :: UniqFM a -> UniqFM a -> UniqFM a
+	{-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _ORIG_ UniqFM plusUFM _N_ #-}
+growIdEnvList :: UniqFM a -> [(Id, a)] -> UniqFM a
+	{-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ #-}
+isNullIdEnv :: UniqFM a -> Bool
+	{-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
+listToUFM :: NamedThing a => [(a, b)] -> UniqFM b
+	{-# GHC_PRAGMA _A_ 2 _U_ 11 _N_ _S_ "LS" _N_ _SPECIALISE_ [ Name, _N_ ] 1 { _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ }, [ TyVar, _N_ ] 1 { _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ }, [ Id, _N_ ] 1 { _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ } #-}
+lookupIdEnv :: UniqFM a -> Id -> Labda a
+	{-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _S_ "SU(U(P)AAA)" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_ #-}
+lookupNoFailIdEnv :: UniqFM a -> Id -> a
+	{-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _S_ "SU(U(P)AAA)" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_ #-}
+lookupUFM :: NamedThing a => UniqFM b -> a -> Labda b
+	{-# GHC_PRAGMA _A_ 3 _U_ 122 _N_ _S_ "U(AAAAAASAAA)SL" {_A_ 3 _U_ 122 _N_ _N_ _N_ _N_} _N_ _SPECIALISE_ [ Name, _N_ ] 1 { _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ }, [ TyVar, _N_ ] 1 { _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ }, [ Id, _N_ ] 1 { _A_ 2 _U_ 21 _N_ _S_ "SU(U(P)AAA)" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_ } #-}
+mapIdEnv :: (a -> b) -> UniqFM a -> UniqFM b
+	{-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _ORIG_ UniqFM mapUFM _N_ #-}
+mapUFM :: (a -> b) -> UniqFM a -> UniqFM b
+	{-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "LS" _N_ _N_ #-}
+minusUFM :: UniqFM a -> UniqFM a -> UniqFM a
+	{-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "SL" _N_ _N_ #-}
+mkIdEnv :: [(Id, a)] -> UniqFM a
+	{-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _SPEC_ _ORIG_ UniqFM listToUFM [ (Id), _N_ ] _N_ #-}
+modifyIdEnv :: UniqFM a -> (a -> a) -> Id -> UniqFM a
+	{-# GHC_PRAGMA _A_ 3 _U_ 211 _N_ _S_ "SLU(U(P)AAA)" {_A_ 3 _U_ 212 _N_ _N_ _N_ _N_} _N_ _N_ #-}
+nullIdEnv :: UniqFM a
+	{-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 1 0 X 1 _/\_ u0 -> _!_ _ORIG_ UniqFM EmptyUFM [u0] [] _N_ #-}
+plusUFM :: UniqFM a -> UniqFM a -> UniqFM a
+	{-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ #-}
+plusUFM_C :: (a -> a -> a) -> UniqFM a -> UniqFM a -> UniqFM a
+	{-# GHC_PRAGMA _A_ 3 _U_ 222 _N_ _S_ "LSS" _N_ _N_ #-}
+rngIdEnv :: UniqFM a -> [a]
+	{-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _ORIG_ UniqFM eltsUFM _N_ #-}
+singletonUFM :: NamedThing a => a -> b -> UniqFM b
+	{-# GHC_PRAGMA _A_ 3 _U_ 122 _N_ _S_ "U(AAAAAASAAA)LL" {_A_ 3 _U_ 122 _N_ _N_ _F_ _IF_ARGS_ 2 3 XXX 6 _/\_ u0 u1 -> \ (u2 :: u0 -> Unique) (u3 :: u0) (u4 :: u1) -> case _APP_  u2 [ u3 ] of { _ALG_ _ORIG_ Unique MkUnique (u5 :: Int#) -> _!_ _ORIG_ UniqFM LeafUFM [u1] [u5, u4]; _NO_DEFLT_ } _N_} _F_ _IF_ARGS_ 2 3 CXX 7 _/\_ u0 u1 -> \ (u2 :: {{NamedThing u0}}) (u3 :: u0) (u4 :: u1) -> case case u2 of { _ALG_ _TUP_10 (u5 :: u0 -> ExportFlag) (u6 :: u0 -> Bool) (u7 :: u0 -> (_PackedString, _PackedString)) (u8 :: u0 -> _PackedString) (u9 :: u0 -> [_PackedString]) (ua :: u0 -> SrcLoc) (ub :: u0 -> Unique) (uc :: u0 -> Bool) (ud :: u0 -> UniType) (ue :: u0 -> Bool) -> _APP_  ub [ u3 ]; _NO_DEFLT_ } of { _ALG_ _ORIG_ Unique MkUnique (uf :: Int#) -> _!_ _ORIG_ UniqFM LeafUFM [u1] [uf, u4]; _NO_DEFLT_ } _SPECIALISE_ [ Name, _N_ ] 1 { _A_ 2 _U_ 22 _N_ _S_ "SL" _N_ _N_ }, [ TyVar, _N_ ] 1 { _A_ 2 _U_ 22 _N_ _S_ "SL" _N_ _N_ }, [ Id, _N_ ] 1 { _A_ 2 _U_ 12 _N_ _S_ "U(U(P)AAA)L" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: Int#) (u2 :: u0) -> _!_ _ORIG_ UniqFM LeafUFM [u0] [u1, u2] _N_} _F_ _IF_ARGS_ 1 2 CX 5 _/\_ u0 -> \ (u1 :: Id) (u2 :: u0) -> case u1 of { _ALG_ _ORIG_ Id Id (u3 :: Unique) (u4 :: UniType) (u5 :: IdInfo) (u6 :: IdDetails) -> case u3 of { _ALG_ _ORIG_ Unique MkUnique (u7 :: Int#) -> _!_ _ORIG_ UniqFM LeafUFM [u0] [u7, u2]; _NO_DEFLT_ }; _NO_DEFLT_ } _N_ } #-}
+u2i :: Unique -> Int#
+	{-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(P)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: Int#) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: Unique) -> case u0 of { _ALG_ _ORIG_ Unique MkUnique (u1 :: Int#) -> u1; _NO_DEFLT_ } _N_ #-}
+unitIdEnv :: Id -> a -> UniqFM a
+	{-# GHC_PRAGMA _A_ 2 _U_ 12 _N_ _S_ "U(U(P)AAA)L" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: Int#) (u2 :: u0) -> _!_ _ORIG_ UniqFM LeafUFM [u0] [u1, u2] _N_} _F_ _IF_ARGS_ 1 2 CX 5 _/\_ u0 -> \ (u1 :: Id) (u2 :: u0) -> case u1 of { _ALG_ _ORIG_ Id Id (u3 :: Unique) (u4 :: UniType) (u5 :: IdInfo) (u6 :: IdDetails) -> case u3 of { _ALG_ _ORIG_ Unique MkUnique (u7 :: Int#) -> _!_ _ORIG_ UniqFM LeafUFM [u0] [u7, u2]; _NO_DEFLT_ }; _NO_DEFLT_ } _N_ #-}
+
diff --git a/ghc/compiler/envs/IdEnv.lhs b/ghc/compiler/envs/IdEnv.lhs
new file mode 100644
index 0000000000..a06ef63719
--- /dev/null
+++ b/ghc/compiler/envs/IdEnv.lhs
@@ -0,0 +1,113 @@
+%
+% (c) The AQUA Project, Glasgow University, 1995
+%
+\section[IdEnv]{Lookup tables that have @Id@ keys}
+
+An interface to the @FiniteMap@ machinery, which exports
+a ``personality'' the same as that of the old @IdEnv@ module.
+
+\begin{code}
+#include "HsVersions.h"
+
+module IdEnv (
+	IdEnv(..),  -- abstract: NOT
+
+	lookupIdEnv, lookupNoFailIdEnv,
+	nullIdEnv, unitIdEnv, mkIdEnv, growIdEnv, growIdEnvList,
+	isNullIdEnv,
+	addOneToIdEnv,
+	delOneFromIdEnv, delManyFromIdEnv, --UNUSED: minusIdEnv,
+	modifyIdEnv, combineIdEnvs,
+	rngIdEnv,
+	mapIdEnv,
+-- UNUSED:	filterIdEnv,
+
+	-- and to make the interface self-sufficient...
+	UniqFM,
+	Id, Unique, Maybe(..)
+	
+	-- and for pragma-friendliness...
+#ifdef USE_ATTACK_PRAGMAS
+	, addToUFM, plusUFM_C, delListFromUFM, delFromUFM, plusUFM,
+	lookupUFM, mapUFM, filterUFM, minusUFM, listToUFM, emptyUFM,
+	eltsUFM, singletonUFM,
+	u2i
+#endif
+    ) where
+
+import UniqFM
+import Id
+import IdInfo
+import Maybes		( Maybe(..), MaybeErr(..) )
+import Outputable
+import Unique		( Unique, u2i )
+import Util
+\end{code}
+
+\begin{code}
+type IdEnv elt = UniqFM elt
+\end{code}
+
+Signatures:
+\begin{code}
+addOneToIdEnv :: IdEnv a -> Id -> a -> IdEnv a
+combineIdEnvs :: (a -> a -> a) -> IdEnv a -> IdEnv a -> IdEnv a
+delManyFromIdEnv :: IdEnv a -> [Id] -> IdEnv a
+delOneFromIdEnv :: IdEnv a -> Id -> IdEnv a
+growIdEnv :: IdEnv a -> IdEnv a -> IdEnv a
+growIdEnvList :: IdEnv a -> [(Id, a)] -> IdEnv a
+isNullIdEnv :: IdEnv a -> Bool
+lookupIdEnv :: IdEnv a -> Id -> Maybe a
+lookupNoFailIdEnv :: IdEnv a -> Id -> a
+mapIdEnv :: (a -> b) -> IdEnv a -> IdEnv b
+--filterIdEnv :: (a -> Bool) -> IdEnv a -> IdEnv a
+--minusIdEnv :: IdEnv a -> IdEnv a -> IdEnv a
+mkIdEnv :: [(Id, a)] -> IdEnv a
+modifyIdEnv :: IdEnv a -> (a -> a) -> Id -> IdEnv a
+nullIdEnv :: IdEnv a
+rngIdEnv :: IdEnv a -> [a]
+unitIdEnv :: Id -> a -> IdEnv a
+\end{code}
+
+\begin{code}
+addOneToIdEnv env id elt = addToUFM env id elt
+
+combineIdEnvs combiner env1 env2 = plusUFM_C combiner env1 env2
+
+delManyFromIdEnv env ids = delListFromUFM env ids
+
+delOneFromIdEnv env id = delFromUFM env id
+
+growIdEnv old_env new_stuff = plusUFM old_env new_stuff
+
+growIdEnvList old_env pairs = plusUFM old_env (listToUFM pairs)
+
+isNullIdEnv env = sizeUFM env == 0
+
+lookupIdEnv env id = lookupUFM env id
+
+lookupNoFailIdEnv env id = case (lookupIdEnv env id) of { Just xx -> xx }
+
+mapIdEnv f env = mapUFM f env
+
+{- UNUSED:
+filterIdEnv p env = filterUFM p env
+minusIdEnv env1 env2 = minusUFM env1 env2
+-}
+
+mkIdEnv stuff = listToUFM stuff
+
+-- modifyIdEnv: Look up a thing in the IdEnv, then mash it with the
+-- modify function, and put it back.
+
+modifyIdEnv env mangle_fn key
+  = case (lookupIdEnv env key) of
+      Nothing -> env
+      Just xx -> addOneToIdEnv env key (mangle_fn xx)
+
+nullIdEnv = emptyUFM
+
+rngIdEnv env = eltsUFM env
+
+unitIdEnv id elt = singletonUFM id elt
+\end{code}
diff --git a/ghc/compiler/envs/InstEnv.hi b/ghc/compiler/envs/InstEnv.hi
new file mode 100644
index 0000000000..fae274925b
--- /dev/null
+++ b/ghc/compiler/envs/InstEnv.hi
@@ -0,0 +1,59 @@
+{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
+interface InstEnv where
+import BasicLit(BasicLit)
+import Class(Class, ClassOp)
+import CoreSyn(CoreAtom, CoreBinding, CoreCaseAlternatives, CoreExpr)
+import CostCentre(CostCentre)
+import HsBinds(Binds)
+import HsExpr(ArithSeqInfo, Expr, Qual)
+import HsLit(Literal)
+import HsMatches(Match)
+import HsPat(InPat, TypecheckedPat)
+import HsTypes(PolyType)
+import Id(Id, IdDetails)
+import IdInfo(IdInfo, SpecEnv, SpecInfo)
+import Inst(Inst, InstOrigin, OverloadedLit)
+import Maybes(Labda, MaybeErr)
+import Name(Name)
+import NameTypes(FullName, ShortName)
+import PreludePS(_PackedString)
+import PrimKind(PrimKind)
+import PrimOps(PrimOp)
+import SplitUniq(SplitUniqSupply)
+import SrcLoc(SrcLoc)
+import TyCon(TyCon)
+import TyVar(TyVar, TyVarTemplate)
+import UniType(UniType)
+import Unique(Unique)
+data Class 	{-# GHC_PRAGMA MkClass Unique FullName TyVarTemplate [Class] [Id] [ClassOp] [Id] [Id] [(UniType, InstTemplate)] [(Class, [Class])] #-}
+type ClassInstEnv = [(UniType, InstTemplate)]
+data ClassOp 	{-# GHC_PRAGMA MkClassOp _PackedString Int UniType #-}
+data CoreExpr a b 	{-# GHC_PRAGMA CoVar b | CoLit BasicLit | CoCon Id [UniType] [CoreAtom b] | CoPrim PrimOp [UniType] [CoreAtom b] | CoLam [a] (CoreExpr a b) | CoTyLam TyVar (CoreExpr a b) | CoApp (CoreExpr a b) (CoreAtom b) | CoTyApp (CoreExpr a b) UniType | CoCase (CoreExpr a b) (CoreCaseAlternatives a b) | CoLet (CoreBinding a b) (CoreExpr a b) | CoSCC CostCentre (CoreExpr a b) #-}
+data Expr a b 	{-# GHC_PRAGMA Var a | Lit Literal | Lam (Match a b) | App (Expr a b) (Expr a b) | OpApp (Expr a b) (Expr a b) (Expr a b) | SectionL (Expr a b) (Expr a b) | SectionR (Expr a b) (Expr a b) | CCall _PackedString [Expr a b] Bool Bool UniType | SCC _PackedString (Expr a b) | Case (Expr a b) [Match a b] | If (Expr a b) (Expr a b) (Expr a b) | Let (Binds a b) (Expr a b) | ListComp (Expr a b) [Qual a b] | ExplicitList [Expr a b] | ExplicitListOut UniType [Expr a b] | ExplicitTuple [Expr a b] | ExprWithTySig (Expr a b) (PolyType a) | ArithSeqIn (ArithSeqInfo a b) | ArithSeqOut (Expr a b) (ArithSeqInfo a b) | TyLam [TyVar] (Expr a b) | TyApp (Expr a b) [UniType] | DictLam [Id] (Expr a b) | DictApp (Expr a b) [Id] | ClassDictLam [Id] [Id] (Expr a b) | Dictionary [Id] [Id] | SingleDict Id #-}
+data Id 	{-# GHC_PRAGMA Id Unique UniType IdInfo IdDetails #-}
+data Inst 	{-# GHC_PRAGMA Dict Unique Class UniType InstOrigin | Method Unique Id [UniType] InstOrigin | LitInst Unique OverloadedLit UniType InstOrigin #-}
+data InstOrigin 	{-# GHC_PRAGMA OccurrenceOf Id SrcLoc | InstanceDeclOrigin SrcLoc | LiteralOrigin Literal SrcLoc | ArithSeqOrigin (ArithSeqInfo Name (InPat Name)) SrcLoc | SignatureOrigin | ClassDeclOrigin SrcLoc | DerivingOrigin (Class -> ([(UniType, InstTemplate)], ClassOp -> SpecEnv)) Class Bool TyCon SrcLoc | InstanceSpecOrigin (Class -> ([(UniType, InstTemplate)], ClassOp -> SpecEnv)) Class UniType SrcLoc | DefaultDeclOrigin SrcLoc | ValSpecOrigin Name SrcLoc | CCallOrigin SrcLoc [Char] (Labda (Expr Name (InPat Name))) | LitLitOrigin SrcLoc [Char] | UnknownOrigin #-}
+data InstTemplate 	{-# GHC_PRAGMA MkInstTemplate Id [UniType] [InstTy] #-}
+data InstTy 	{-# GHC_PRAGMA DictTy Class UniType | MethodTy Id [UniType] #-}
+type InstanceMapper = Class -> ([(UniType, InstTemplate)], ClassOp -> SpecEnv)
+data Labda a 	{-# GHC_PRAGMA Hamna | Ni a #-}
+type MatchEnv a b = [(a, b)]
+data MaybeErr a b 	{-# GHC_PRAGMA Succeeded a | Failed b #-}
+type MethodInstInfo = (Id, [UniType], InstTemplate)
+data TypecheckedPat 	{-# GHC_PRAGMA WildPat UniType | VarPat Id | LazyPat TypecheckedPat | AsPat Id TypecheckedPat | ConPat Id UniType [TypecheckedPat] | ConOpPat TypecheckedPat Id TypecheckedPat UniType | ListPat UniType [TypecheckedPat] | TuplePat [TypecheckedPat] | LitPat Literal UniType | NPat Literal UniType (Expr Id TypecheckedPat) | NPlusKPat Id Literal UniType (Expr Id TypecheckedPat) (Expr Id TypecheckedPat) (Expr Id TypecheckedPat) #-}
+data SpecInfo 	{-# GHC_PRAGMA SpecInfo [Labda UniType] Int Id #-}
+data SplitUniqSupply 	{-# GHC_PRAGMA MkSplitUniqSupply Int SplitUniqSupply SplitUniqSupply #-}
+data TyCon 	{-# GHC_PRAGMA SynonymTyCon Unique FullName Int [TyVarTemplate] UniType Bool | DataTyCon Unique FullName Int [TyVarTemplate] [Id] [Class] Bool | TupleTyCon Int | PrimTyCon Unique FullName Int ([PrimKind] -> PrimKind) | SpecTyCon TyCon [Labda UniType] #-}
+data TyVarTemplate 	{-# GHC_PRAGMA SysTyVarTemplate Unique _PackedString | UserTyVarTemplate Unique ShortName #-}
+data UniType 	{-# GHC_PRAGMA UniTyVar TyVar | UniFun UniType UniType | UniData TyCon [UniType] | UniSyn TyCon [UniType] UniType | UniDict Class UniType | UniTyVarTemplate TyVarTemplate | UniForall TyVarTemplate UniType #-}
+addClassInst :: Class -> [(UniType, InstTemplate)] -> UniType -> Id -> [TyVarTemplate] -> [(Class, UniType)] -> SrcLoc -> MaybeErr [(UniType, InstTemplate)] (Class, (UniType, SrcLoc), (UniType, SrcLoc))
+	{-# GHC_PRAGMA _A_ 7 _U_ 2222112 _N_ _S_ "LSLLLLL" _N_ _N_ #-}
+lookupClassInstAtSimpleType :: Class -> UniType -> Labda Id
+	{-# GHC_PRAGMA _A_ 2 _U_ 12 _N_ _S_ "U(AAAAAAAASA)L" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_ #-}
+lookupInst :: SplitUniqSupply -> Inst -> Labda (Expr Id TypecheckedPat, [Inst])
+	{-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _S_ "LS" _N_ _N_ #-}
+lookupNoBindInst :: SplitUniqSupply -> Inst -> Labda [Inst]
+	{-# GHC_PRAGMA _A_ 2 _U_ 11 _N_ _S_ "LS" _N_ _N_ #-}
+nullMEnv :: [(a, b)]
+	{-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 2 0 X 1 _/\_ u0 u1 -> _!_ _NIL_ [(u0, u1)] [] _N_ #-}
+
diff --git a/ghc/compiler/envs/InstEnv.lhs b/ghc/compiler/envs/InstEnv.lhs
new file mode 100644
index 0000000000..edc3e2fa69
--- /dev/null
+++ b/ghc/compiler/envs/InstEnv.lhs
@@ -0,0 +1,549 @@
+%
+% (c) The GRASP/AQUA Project, Glasgow University, 1993-1995
+%
+\section[InstEnv]{Instance environments}
+
+\begin{code}
+#include "HsVersions.h"
+
+module InstEnv (
+	-- these types could use some abstractification (??? ToDo)
+	ClassInstEnv(..), -- OLD: IdInstEnv(..),
+	InstTemplate, InstTy,
+	MethodInstInfo(..),	-- needs to be exported? (ToDo)
+	InstanceMapper(..),	-- widely-used synonym
+
+--	instMethod, instTemplate, -- no need to export
+	addClassInst, {- NOT USED addConstMethInst, -}
+	lookupInst,
+	lookupClassInstAtSimpleType,
+	lookupNoBindInst,
+
+	MatchEnv(..),	-- mk more abstract (??? ToDo)
+	nullMEnv,
+--	mkMEnv, lookupMEnv, insertMEnv, -- no need to export
+
+	-- and to make the interface self-sufficient...
+	Class, ClassOp, CoreExpr, Expr, TypecheckedPat, Id,
+	Inst, InstOrigin, Maybe, MaybeErr, TyVarTemplate, TyCon,
+	UniType, SplitUniqSupply, SpecInfo
+    ) where
+
+IMPORT_Trace		-- ToDo: rm (debugging)
+
+import AbsPrel		( intTyCon, --wordTyCon, addrTyCon,
+			  floatTyCon, doubleTyCon, charDataCon, intDataCon,
+			  wordDataCon, addrDataCon, floatDataCon,
+			  doubleDataCon,
+			  intPrimTyCon, doublePrimTyCon
+			)
+import AbsSyn		-- TypecheckedExpr, etc.
+import AbsUniType
+import Id
+import IdInfo
+import Inst
+import Maybes		-- most of it
+import Outputable	( isExported )
+import PlainCore	-- PlainCoreExpr, etc.
+import Pretty
+import PrimKind		-- rather grubby import (ToDo?)
+import SplitUniq
+import Util
+\end{code}
+
+%************************************************************************
+%*									*
+\subsection[InstEnv-types]{Type declarations}
+%*									*
+%************************************************************************
+
+\begin{code}
+type InstanceMapper
+  = Class -> (ClassInstEnv, ClassOp -> SpecEnv)
+
+type ClassInstEnv = MatchEnv UniType   InstTemplate -- Instances of dicts
+--OLD: type IdInstEnv = MatchEnv [UniType] InstTemplate -- Instances of ids
+
+data InstTemplate
+  = MkInstTemplate
+	Id		-- A fully polymorphic Id; it is the function
+			-- which produces the Id instance or dict from
+			-- the pieces specified by the rest of the
+			-- template.  Its SrcLoc tells where the
+			-- instance was defined.
+	[UniType]	-- Apply it to these types, suitably instantiated
+	[InstTy]	-- and instances of these things
+
+type MethodInstInfo = (Id, [UniType], InstTemplate) -- Specifies a method instance
+\end{code}
+
+There is an important consistency constraint between the @MatchEnv@s
+in and the @InstTemplate@s inside them: the @UniType@(s) which is/are
+the key for the @MatchEnv@ must contain only @TyVarTemplates@, and
+these must be a superset of the @TyVarTemplates@ mentioned in the
+corresponding @InstTemplate@.
+
+Reason: the lookup process matches the key against the desired value,
+returning a substitution which is used to instantiate the template.
+
+\begin{code}
+data InstTy
+  = DictTy	Class UniType
+  | MethodTy	Id    [UniType]
+\end{code}
+
+	MkInstTemplate f tvs insts
+
+says that, given a particular mapping of type variables tvs to some
+types tys, the value which is the required instance is
+
+	f tys (insts [tys/tvs])
+
+
+@instMethod@ is used if there is no instance for a method; then it is
+expressed in terms of the corresponding dictionary (or possibly, in a
+wired-in case only, dictionaries).
+
+\begin{code}
+instMethod :: SplitUniqSupply
+	   -> InstOrigin
+	   -> Id -> [UniType]
+	   -> (TypecheckedExpr, [Inst])
+
+instMethod uniqs orig id tys
+  = (mkDictApp (mkTyApp (Var id) tys) dicts,
+     insts)
+  where
+   (tyvars, theta, tau_ty) = splitType (getIdUniType id)
+   tenv			   = tyvars `zipEqual` tys
+   insts		   = mk_dict_insts uniqs theta
+   dicts		   = map mkInstId insts
+
+   mk_dict_insts us [] = []
+   mk_dict_insts us ((clas, ty) : rest)
+      = case splitUniqSupply us of { (s1, s2) ->
+        (Dict (getSUnique s1) clas (instantiateTauTy tenv ty) orig)
+	: mk_dict_insts s2 rest
+	}
+\end{code}
+
+@instTemplate@ is used if there is an instance for a method or dictionary.
+
+\begin{code}
+instTemplate :: SplitUniqSupply
+	     -> InstOrigin
+	     -> [(TyVarTemplate, UniType)]
+	     -> InstTemplate
+	     -> (TypecheckedExpr, [Inst])
+
+instTemplate uniqs orig tenv (MkInstTemplate id ty_tmpls inst_tys)
+  = (mkDictApp (mkTyApp (Var id) ty_args) ids,	-- ToDo: not strictly a dict app
+						-- for Method inst_tys
+     insts)
+  where
+    ty_args	    = map (instantiateTy tenv) ty_tmpls
+    insts	    = mk_insts uniqs inst_tys
+    ids		    = map mkInstId insts
+
+    mk_insts us [] = []
+    mk_insts us (inst_ty : rest)
+      = case splitUniqSupply us of { (s1, s2) ->
+	let
+	    uniq = getSUnique s1
+	in
+        (case inst_ty of
+	   DictTy clas ty  -> Dict uniq clas (instantiateTy tenv ty) orig
+	   MethodTy id tys -> Method uniq id (map (instantiateTy tenv) tys) orig
+	) : mk_insts s2 rest
+	}
+\end{code}
+
+
+%************************************************************************
+%*									*
+\subsection[InstEnv-adding]{Adding new class instances}
+%*									*
+%************************************************************************
+
+@addClassInstance@ adds the appropriate stuff to the @ClassInstEnv@ based on
+information from a single instance declaration.	 It complains about
+any overlap with an existing instance.
+
+Notice that we manufacture the @DictFunId@ and @ConstMethodId@s from
+scratch here, rather than passing them in.  This means a small amount
+of duplication (no big deal) and that we can't attach a single
+canonical unfolding; but they don't have a slot for unfoldings
+anyway...  This could be improved.  (We do, however, snaffle in the
+pragma info from the interface...)
+
+{\em Random notes}
+
+\begin{verbatim}
+class Foo a where
+  fop :: Ord b => a -> b -> b -> a
+
+instance Foo Int where
+  fop x y z = if y<z then x else fop x z y
+
+instance Foo a => Foo [a] where
+  fop []     y z = []
+  fop (x:xs) y z = [fop x y z]
+\end{verbatim}
+
+
+For the Int instance we add to the ??? envt
+\begin{verbatim}
+  (ClassOpId Foo fop) |--> [Int,b] |--> InstTemplate (ConstMethodId Foo fop Int) [b] [Ord b]
+\end{verbatim}
+
+If there are no type variables, @addClassInstance@ adds constant
+instances for those class ops not mentioned in the class-op details
+(possibly using the pragma info that was passed in).  This MUST
+be the same decision as that by @tcInstDecls2@ about whether to
+generate constant methods.  NB: A slightly more permissive version
+would base the decision on the context being empty, but there is
+slightly more admin associated and the benefits are very slight; the
+context is seldom empty unless there are no tyvars involved.
+
+Note: the way of specifying class-op instance details is INADEQUATE
+for polymorphic class ops.  That just means you can't specify clever
+instances for them via this function.
+
+\begin{code}
+addClassInst
+    :: Class			-- class in question (for err msg only)    	
+    -> ClassInstEnv		-- Incoming envt
+    -> UniType			-- The instance type
+    -> Id			-- Dict fun id to apply
+    -> [TyVarTemplate]		-- Types to which (after instantiation) to apply the dfun
+    -> ThetaType		-- Dicts to which to apply the dfun
+    -> SrcLoc			-- associated SrcLoc (for err msg only)
+    -> MaybeErr
+	  ClassInstEnv		-- Success
+	  (Class, (UniType, SrcLoc),  -- Failure: the overlapping pair
+		  (UniType, SrcLoc))
+
+addClassInst clas inst_env inst_ty dfun_id inst_tyvars dfun_theta locn
+  = case (insertMEnv matchTy inst_env inst_ty dict_template) of
+      Succeeded inst_env' -> Succeeded inst_env'
+      Failed (ty', MkInstTemplate id' _ _)
+	-> Failed (clas, (inst_ty, locn), (ty', getSrcLoc id'))
+  where
+    dict_template = MkInstTemplate dfun_id 
+				   (map mkTyVarTemplateTy inst_tyvars) 
+				   (unzipWith DictTy dfun_theta)
+\end{code}
+
+============ NOT USED =============
+@addConstMethInst@ panics on overlap, because @addClassInst@ has already found
+any overlap.
+
+\begin{pseudocode}
+addConstMethInst :: IdInstEnv
+		 -> UniType		-- The instance type
+		 -> Id			-- The constant method
+		 -> [TyVarTemplate]	-- Apply method to these (as above)
+		 -> IdInstEnv
+
+addConstMethInst inst_env inst_ty meth_id inst_tyvars
+  = case (insertMEnv matchTys inst_env [inst_ty] template) of
+      Succeeded inst_env' -> inst_env'
+      Failed (tys', MkInstTemplate id' _ _) ->
+	pprPanic "addConstMethInst:"
+		(ppSep [ppr PprDebug meth_id,
+		        ppr PprDebug inst_ty,
+			ppr PprDebug id'])
+  where
+     template = MkInstTemplate meth_id (map mkTyVarTemplateTy inst_tyvars) []
+	-- Constant method just needs to be applied to tyvars
+	-- (which are usually empty)
+\end{pseudocode}
+
+@mkIdInstEnv@ is useful in the simple case where we've a list of
+@(types, id)@ pairs; the \tr{id} is the \tr{types} specialisation of
+some other Id (in which the resulting IdInstEnv will doubtless be
+embedded.  There's no messing about with type variables or
+dictionaries here.
+
+\begin{code}
+{- OLD:
+mkIdInstEnv :: [([TauType],Id)] -> IdInstEnv
+
+mkIdInstEnv [] = nullMEnv
+mkIdInstEnv ((tys,id) : rest) 
+  = let
+	inst_env = mkIdInstEnv rest
+    in
+    case (insertMEnv matchTys inst_env tys template) of
+      Succeeded inst_env' -> inst_env'
+      Failed _ -> panic "Failed in mkIdInstEnv"
+  where
+    template = MkInstTemplate id [] []
+-}
+\end{code}
+
+%************************************************************************
+%*									*
+\subsection[InstEnv-lookup]{Performing lookup}
+%*									*
+%************************************************************************
+
+\begin{code}
+lookupInst :: SplitUniqSupply
+	   -> Inst
+	   -> Maybe (TypecheckedExpr,
+		     [Inst])
+
+lookupInst uniqs (Dict _ clas ty orig)
+  = if isTyVarTy ty then
+	Nothing	-- No instances of a class at a type variable
+    else
+      case (lookupMEnv matchTy inst_env ty) of
+	Nothing		    -> Nothing
+	Just (_,tenv,templ) -> Just (instTemplate uniqs orig tenv templ)
+  where
+    inst_env
+      = case orig of
+
+	  -- During deriving and instance specialisation operations
+	  -- we can't get the instances of the class from inside the
+	  -- class, because the latter ain't ready yet.  Instead we
+	  -- find a mapping from classes to envts inside the dict origin.
+	  -- (A Simon hack [WDP])
+
+	  DerivingOrigin inst_mapper _ _ _ _ -> fst (inst_mapper clas)
+
+	  InstanceSpecOrigin inst_mapper _ _ _ -> fst (inst_mapper clas)
+
+	  -- Usually we just get the instances of the class from
+	  -- inside the class itself.
+
+	  other -> getClassInstEnv clas
+
+lookupInst uniqs (Method _ id tys orig)
+  = if (all isTyVarTy tys) then
+	general_case	-- Instance types are all type variables, so there can't be
+			-- a special instance for this method
+
+    else	-- Get the inst env from the Id, and look up in it
+      case (lookupSpecEnv (getIdSpecialisation id) tys) of
+	Nothing		    -> general_case
+	Just (spec_id, types_left, num_dicts_to_toss)
+	  -> Just (instMethod uniqs orig spec_id types_left)
+  where
+    general_case = Just (instMethod uniqs orig id tys)
+\end{code}
+
+Now "overloaded" literals: the plain truth is that the compiler
+is intimately familiar w/ the types Int, Integer, Float, and Double;
+for everything else, we actually conjure up an appropriately-applied
+fromInteger/fromRational, as the Haskell report suggests.
+
+\begin{code}
+lookupInst uniqs (LitInst u (OverloadedIntegral i from_int from_integer) ty orig)
+  = Just (
+    case (getUniDataTyCon_maybe ty) of	-- this way is *unflummoxed* by synonyms
+      Just (tycon, [], _)
+        | tycon == intPrimTyCon		-> (intprim_lit,    [])
+	| tycon == doublePrimTyCon	-> (doubleprim_lit, [])
+        | tycon == intTyCon		-> (int_lit,        [])
+	| tycon == doubleTyCon		-> (double_lit,     [])
+	| tycon == floatTyCon		-> (float_lit,      [])
+--	| tycon == wordTyCon		-> (word_lit,       [])
+--	| tycon == addrTyCon		-> (addr_lit,       [])
+
+      _{-otherwise-} ->
+
+	if (i >= toInteger minInt && i <= toInteger maxInt) then
+	    -- It's overloaded but small enough to fit into an Int
+
+	    let u2		= getSUnique uniqs
+		method	= Method u2 from_int [ty] orig
+	    in
+	    (App (Var (mkInstId method)) int_lit, [method])
+
+	else
+	    -- Alas, it is overloaded and a big literal!
+
+	    let u2	   = getSUnique uniqs
+		method = Method u2 from_integer [ty] orig
+	    in
+	    (App (Var (mkInstId method)) (Lit (IntLit i)), [method])
+    )
+  where
+#if __GLASGOW_HASKELL__ <= 22
+    iD = ((fromInteger i) :: Double)
+#else
+    iD = ((fromInteger i) :: Rational)
+#endif
+    intprim_lit    = Lit (IntPrimLit i)
+    doubleprim_lit = Lit (DoublePrimLit iD)
+    int_lit        = App (Var intDataCon)    intprim_lit
+    double_lit     = App (Var doubleDataCon) doubleprim_lit
+    float_lit      = App (Var floatDataCon)  (Lit (FloatPrimLit iD))
+--  word_lit       = App (Var wordDataCon)   intprim_lit
+--  addr_lit       = App (Var addrDataCon)   intprim_lit
+
+lookupInst uniqs (LitInst u (OverloadedFractional f from_rational) ty orig)
+  = Just (
+    case (getUniDataTyCon_maybe ty) of	-- this way is *unflummoxed* by synonyms
+      Just (tycon, [], _)
+	| tycon == doublePrimTyCon -> (doubleprim_lit, [])
+	| tycon == doubleTyCon	   -> (double_lit, [])
+	| tycon == floatTyCon	   -> (float_lit,  [])
+
+      _ {-otherwise-} ->    -- gotta fromRational it...
+	--pprTrace "lookupInst:fractional lit ty?:" (ppr PprDebug ty) (
+	let
+	    u2	   = getSUnique uniqs
+	    method = Method u2 from_rational [ty] orig
+	in
+	(App (Var (mkInstId method)) (Lit (FracLit f)), [method])
+	--)
+    )
+  where
+#if __GLASGOW_HASKELL__ <= 22
+    fD = ((fromRational f) :: Double)
+#else
+    fD = f
+#endif
+    doubleprim_lit = Lit (DoublePrimLit fD)
+    double_lit     = App (Var doubleDataCon) doubleprim_lit
+    float_lit      = App (Var floatDataCon)  (Lit (FloatPrimLit  fD))
+\end{code}
+
+There is a second, simpler interface, when you want an instance
+of a class at a given nullary type constructor.	 It just returns
+the appropriate dictionary if it exists.  It is used only when resolving
+ambiguous dictionaries.
+
+\begin{code}
+lookupClassInstAtSimpleType :: Class -> UniType -> Maybe Id
+
+lookupClassInstAtSimpleType clas ty
+  = case (lookupMEnv matchTy (getClassInstEnv clas) ty) of
+      Nothing				   -> Nothing
+      Just (_,_,MkInstTemplate dict [] []) -> Just dict
+\end{code}
+
+Notice in the above that the type constructors in the default list
+should all have arity zero, so there should be no type variables
+or thetas in the instance declaration.
+
+There's yet a third interface for Insts which need no binding.
+They are used to record constraints on type variables, notably
+for CCall arguments and results.
+
+\begin{code}
+lookupNoBindInst :: SplitUniqSupply
+	         -> Inst
+	         -> Maybe [Inst]
+
+lookupNoBindInst uniqs (Dict _ clas ty orig)
+  = if isTyVarTy ty then
+	Nothing	-- No instances of a class at a type variable
+    else
+      case (lookupMEnv matchTy inst_env ty) of
+	Nothing		    -> Nothing
+	Just (_,tenv,templ) ->
+	  case (instTemplate uniqs orig tenv templ) of
+	    (bottom_rhs, insts)
+	      -> Just insts
+		-- The idea here is that the expression built by
+		-- instTemplate isn't relevant; indeed, it might well
+		-- be a place-holder bottom value.
+  where
+    inst_env = getClassInstEnv clas
+\end{code}
+
+%************************************************************************
+%*									*
+\subsection[MatchEnv]{Matching environments}
+%*									*
+%************************************************************************
+
+``Matching'' environments allow you to bind a template to a value;
+when you look up in it, you supply a value which is matched against
+the template.
+
+\begin{code}
+type MatchEnv key value = [(key, value)]
+\end{code}
+
+For now we just use association lists.	The list is maintained sorted
+in order of {\em decreasing specificness} of @key@, so that the first
+match will be the most specific.
+
+\begin{code}
+nullMEnv :: MatchEnv a b
+nullMEnv = []
+
+mkMEnv :: [(key, value)] -> MatchEnv key value
+mkMEnv stuff = stuff
+\end{code}
+
+@lookupMEnv@ looks up in a @MatchEnv@.
+It
+simply takes the first match, should be the most specific.
+
+\begin{code}
+lookupMEnv :: (key {- template -} ->	-- Matching function
+	       key {- instance -} ->
+	       Maybe match_info)
+	   -> MatchEnv key value	-- The envt
+	   -> key			-- Key
+	   -> Maybe (key,		-- Template
+		     match_info,	-- Match info returned by matching fn
+		     value)		-- Value
+
+lookupMEnv key_match alist key
+  = find alist
+  where
+    find [] = Nothing
+    find ((tpl, val) : rest)
+      = case key_match tpl key of
+	  Nothing	  -> find rest
+	  Just match_info -> Just (tpl, match_info, val)
+\end{code}
+
+@insertMEnv@ extends a match environment, checking for overlaps.
+
+\begin{code}
+insertMEnv :: (key {- template -} ->		-- Matching function
+	       key {- instance -} ->
+	       Maybe match_info)
+	   -> MatchEnv key value		-- Envt
+	   -> key -> value			-- New item
+	   -> MaybeErr (MatchEnv key value)	-- Success...
+		       (key, value)		-- Failure: Offending overlap
+
+insertMEnv match_fn alist key value
+  = insert alist
+  where
+    -- insert has to put the new item in BEFORE any keys which are
+    -- LESS SPECIFIC than the new key, and AFTER any keys which are
+    -- MORE SPECIFIC The list is maintained in specific-ness order, so
+    -- we just stick it in either last, or just before the first key
+    -- of which the new key is an instance.  We check for overlap at
+    -- that point.
+
+    insert [] = returnMaB [(key, value)]
+    insert ((t,v) : rest)
+      = case (match_fn t key) of
+	  Nothing ->
+	    -- New key is not an instance of this existing one, so
+	    -- continue down the list.
+	    insert rest			`thenMaB` (\ rest' ->
+	    returnMaB ((t,v):rest') )
+
+	  Just match_info ->
+	    -- New key *is* an instance of the old one, so check the
+	    -- other way round in case of identity.
+
+	    case (match_fn key t) of
+	      Just _  -> failMaB (t,v)
+			 -- Oops; overlap
+
+	      Nothing -> returnMaB ((key,value):(t,v):rest)
+			 -- All ok; insert here
+\end{code}
diff --git a/ghc/compiler/envs/LIE.hi b/ghc/compiler/envs/LIE.hi
new file mode 100644
index 0000000000..eb0f193ae8
--- /dev/null
+++ b/ghc/compiler/envs/LIE.hi
@@ -0,0 +1,20 @@
+{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
+interface LIE where
+import Class(Class)
+import Id(Id)
+import Inst(Inst, InstOrigin, OverloadedLit)
+import UniType(UniType)
+import Unique(Unique)
+data Inst 	{-# GHC_PRAGMA Dict Unique Class UniType InstOrigin | Method Unique Id [UniType] InstOrigin | LitInst Unique OverloadedLit UniType InstOrigin #-}
+data LIE 	{-# GHC_PRAGMA MkLIE [Inst] #-}
+mkLIE :: [Inst] -> LIE
+	{-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 2 \ (u0 :: [Inst]) -> _!_ _ORIG_ LIE MkLIE [] [u0] _N_ #-}
+nullLIE :: LIE
+	{-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
+plusLIE :: LIE -> LIE -> LIE
+	{-# GHC_PRAGMA _A_ 2 _U_ 11 _N_ _S_ "U(L)U(L)" {_A_ 2 _U_ 12 _N_ _N_ _N_ _N_} _N_ _N_ #-}
+unMkLIE :: LIE -> [Inst]
+	{-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(S)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: [Inst]) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: LIE) -> case u0 of { _ALG_ _ORIG_ LIE MkLIE (u1 :: [Inst]) -> u1; _NO_DEFLT_ } _N_ #-}
+unitLIE :: Inst -> LIE
+	{-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _N_ _N_ #-}
+
diff --git a/ghc/compiler/envs/LIE.lhs b/ghc/compiler/envs/LIE.lhs
new file mode 100644
index 0000000000..cd3e38cd62
--- /dev/null
+++ b/ghc/compiler/envs/LIE.lhs
@@ -0,0 +1,44 @@
+%
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1994
+%
+\section[LIE]{Id instance environment}
+
+This is not really an ``environment.''
+
+\begin{code}
+#include "HsVersions.h"
+
+module LIE (
+	LIE,		-- abstract type
+	mkLIE, nullLIE, unitLIE, unMkLIE, plusLIE,
+
+	-- imported things so this module's interface is self-contained
+	Inst
+    ) where
+
+import Inst		( Inst )
+import Outputable
+import Util
+\end{code}
+
+%************************************************************************
+%*									*
+\subsection[LIE-building]{Building LIEs}
+%*									*
+%************************************************************************
+
+\begin{code}
+data LIE = MkLIE [Inst]
+
+mkLIE = MkLIE
+
+nullLIE   = MkLIE []
+unitLIE x = MkLIE [x]
+
+unMkLIE :: LIE -> [Inst]
+unMkLIE (MkLIE insts) = insts
+
+plusLIE :: LIE -> LIE -> LIE
+plusLIE (MkLIE lie1) (MkLIE lie2)
+  = MkLIE (lie1 ++ lie2)
+\end{code}
diff --git a/ghc/compiler/envs/TCE.hi b/ghc/compiler/envs/TCE.hi
new file mode 100644
index 0000000000..7903554419
--- /dev/null
+++ b/ghc/compiler/envs/TCE.hi
@@ -0,0 +1,50 @@
+{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
+interface TCE where
+import CharSeq(CSeq)
+import Class(Class)
+import ErrUtils(Error(..))
+import Id(Id)
+import Maybes(Labda, MaybeErr)
+import Name(Name)
+import NameTypes(FullName, ShortName)
+import PreludePS(_PackedString)
+import Pretty(Delay, PprStyle, Pretty(..), PrettyRep)
+import PrimKind(PrimKind)
+import SrcLoc(SrcLoc)
+import TyCon(TyCon)
+import TyVar(TyVarTemplate)
+import UniType(UniType)
+import UniqFM(UniqFM, eltsUFM, emptyUFM, plusUFM, singletonDirectlyUFM)
+import Unique(Unique, u2i)
+type Error = PprStyle -> Int -> Bool -> PrettyRep
+data MaybeErr a b 	{-# GHC_PRAGMA Succeeded a | Failed b #-}
+data Name 	{-# GHC_PRAGMA Short Unique ShortName | WiredInTyCon TyCon | WiredInVal Id | PreludeVal Unique FullName | PreludeTyCon Unique FullName Int Bool | PreludeClass Unique FullName | OtherTyCon Unique FullName Int Bool [Name] | OtherClass Unique FullName [Name] | OtherTopId Unique FullName | ClassOpName Unique Name _PackedString Int | Unbound _PackedString #-}
+type Pretty = Int -> Bool -> PrettyRep
+data PrettyRep 	{-# GHC_PRAGMA MkPrettyRep CSeq (Delay Int) Bool Bool #-}
+data SrcLoc 	{-# GHC_PRAGMA SrcLoc _PackedString _PackedString | SrcLoc2 _PackedString Int# #-}
+type TCE = UniqFM TyCon
+data TyCon 	{-# GHC_PRAGMA SynonymTyCon Unique FullName Int [TyVarTemplate] UniType Bool | DataTyCon Unique FullName Int [TyVarTemplate] [Id] [Class] Bool | TupleTyCon Int | PrimTyCon Unique FullName Int ([PrimKind] -> PrimKind) | SpecTyCon TyCon [Labda UniType] #-}
+data UniqFM a 	{-# GHC_PRAGMA EmptyUFM | LeafUFM Int# a | NodeUFM Int# Int# (UniqFM a) (UniqFM a) #-}
+checkTypeCycles :: UniqFM TyCon -> MaybeErr () (PprStyle -> Int -> Bool -> PrettyRep)
+	{-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-}
+eltsUFM :: UniqFM a -> [a]
+	{-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-}
+emptyUFM :: UniqFM a
+	{-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 1 0 X 1 _/\_ u0 -> _!_ _ORIG_ UniqFM EmptyUFM [u0] [] _N_ #-}
+lookupTCE :: UniqFM TyCon -> Name -> TyCon
+	{-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "LS" _N_ _N_ #-}
+nullTCE :: UniqFM TyCon
+	{-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _!_ _ORIG_ UniqFM EmptyUFM [TyCon] [] _N_ #-}
+plusTCE :: UniqFM TyCon -> UniqFM TyCon -> UniqFM TyCon
+	{-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _TYAPP_  _ORIG_ UniqFM plusUFM { TyCon } _N_ #-}
+plusUFM :: UniqFM a -> UniqFM a -> UniqFM a
+	{-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ #-}
+rngTCE :: UniqFM TyCon -> [TyCon]
+	{-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _TYAPP_  _ORIG_ UniqFM eltsUFM { TyCon } _N_ #-}
+singletonDirectlyUFM :: Unique -> a -> UniqFM a
+	{-# GHC_PRAGMA _A_ 2 _U_ 12 _N_ _S_ "U(P)L" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: Int#) (u2 :: u0) -> _!_ _ORIG_ UniqFM LeafUFM [u0] [u1, u2] _N_} _F_ _IF_ARGS_ 1 2 CX 4 _/\_ u0 -> \ (u1 :: Unique) (u2 :: u0) -> case u1 of { _ALG_ _ORIG_ Unique MkUnique (u3 :: Int#) -> _!_ _ORIG_ UniqFM LeafUFM [u0] [u3, u2]; _NO_DEFLT_ } _N_ #-}
+u2i :: Unique -> Int#
+	{-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(P)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: Int#) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: Unique) -> case u0 of { _ALG_ _ORIG_ Unique MkUnique (u1 :: Int#) -> u1; _NO_DEFLT_ } _N_ #-}
+unitTCE :: Unique -> TyCon -> UniqFM TyCon
+	{-# GHC_PRAGMA _A_ 2 _U_ 12 _N_ _S_ "U(P)L" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 3 \ (u0 :: Int#) (u1 :: TyCon) -> _!_ _ORIG_ UniqFM LeafUFM [TyCon] [u0, u1] _N_} _F_ _IF_ARGS_ 0 2 CX 4 \ (u0 :: Unique) (u1 :: TyCon) -> case u0 of { _ALG_ _ORIG_ Unique MkUnique (u2 :: Int#) -> _!_ _ORIG_ UniqFM LeafUFM [TyCon] [u2, u1]; _NO_DEFLT_ } _N_ #-}
+
diff --git a/ghc/compiler/envs/TCE.lhs b/ghc/compiler/envs/TCE.lhs
new file mode 100644
index 0000000000..aac6057bcf
--- /dev/null
+++ b/ghc/compiler/envs/TCE.lhs
@@ -0,0 +1,110 @@
+%
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
+%
+\section[TCE]{Type constructor environment}
+
+\begin{code}
+#include "HsVersions.h"
+
+module TCE (
+	TCE(..), UniqFM,
+	nullTCE, unitTCE,
+	rngTCE,
+	lookupTCE,
+	plusTCE, checkTypeCycles,
+-- NOT REALLY USED: printTypeInfoForPop,
+
+	-- and to make the interface self-sufficient...
+	MaybeErr, Name, TyCon,
+	Error(..), SrcLoc, Pretty(..), PrettyRep
+
+	IF_ATTACK_PRAGMAS(COMMA emptyUFM COMMA plusUFM)
+	IF_ATTACK_PRAGMAS(COMMA eltsUFM  COMMA singletonDirectlyUFM)
+	IF_ATTACK_PRAGMAS(COMMA u2i)
+   ) where
+
+import AbsUniType	( getMentionedTyCons, isDataTyCon, getTyConDataCons,
+			  TyCon, Arity(..), Class, UniType
+			  IF_ATTACK_PRAGMAS(COMMA cmpTyCon COMMA cmpClass)
+			  IF_ATTACK_PRAGMAS(COMMA cmpUniType)
+			)
+import Digraph		( topologicalSort )
+import Errors		-- notably typeCycleErr
+import Id		( getDataConArity, Id, DataCon(..) )
+import Maybes		( Maybe(..), MaybeErr(..) )
+import Name
+import Outputable
+import Pretty
+import UniqFM		-- basic environment handling
+import Unique		( Unique )
+import Util
+\end{code}
+
+\begin{code}
+--data TCE = MkTCE (UniqFM TyCon)
+type TCE = UniqFM TyCon
+#define MkTCE {--}
+-- also killed instance TCE, exported non-abstractly
+
+nullTCE :: TCE
+nullTCE = MkTCE emptyUFM
+
+unitTCE :: Unique -> TyCon -> TCE
+unitTCE uniq tycon = MkTCE (singletonDirectlyUFM uniq tycon)
+
+rngTCE :: TCE -> [TyCon]
+rngTCE (MkTCE tce) = eltsUFM tce
+
+lookupTCE :: TCE -> Name -> TyCon
+lookupTCE (MkTCE tce) name
+  = case name of
+      WiredInTyCon tycon       -> tycon
+      PreludeTyCon key _ _ _   -> case (lookupDirectlyUFM tce key) of
+				    Just tycon -> tycon
+				    Nothing    -> err_msg
+      OtherTyCon uniq _ _ _ _  -> case (lookupDirectlyUFM tce uniq) of
+				    Just tycon -> tycon
+				    Nothing    -> err_msg
+  where
+    err_msg = error ("ERROR: in looking up a type constructor! "++(ppShow 80 (ppr PprDebug name))++"\n(This can happen if you use `-fno-implicit-prelude'\nor you hide or change the system's Prelude.hi in some way.\nA -fhaskell-1.3 flag, or lack thereof, can trigger this error.)\n")
+
+plusTCE :: TCE -> TCE -> TCE
+plusTCE (MkTCE tce1) (MkTCE tce2) = MkTCE (plusUFM tce1 tce2)
+\end{code}
+
+\begin{code}
+checkTypeCycles :: TCE -> MaybeErr () Error
+checkTypeCycles tce
+ = case (topologicalSort (==) edges vertices) of
+    Succeeded ordering -> Succeeded ()
+    Failed cycles
+         -> Failed (typeCycleErr (map (\ c -> map fmt_tycon c) cycles))
+	      where
+		fmt_tycon c = (ppr PprForUser c, getSrcLoc c)
+   where
+   vertices = [ vertex1 | (vertex1, vertex2) <- edges]
+   edges = concat (map get_edges (rngTCE tce))
+	    where
+	    get_edges tycon = [(tycon, dep) | dep <- getMentionedTyCons tycon]
+		-- Make an arc for every dependency
+\end{code}
+
+\begin{code}
+{- NOT REALLY USED:
+printTypeInfoForPop :: TCE -> Pretty
+
+printTypeInfoForPop (MkTCE tce)
+  = ppAboves [ pp_type tc | tc <- eltsUFM tce, isDataTyCon tc ]
+  where
+    pp_type tycon
+      = ppBesides [
+	    ppStr "data ",
+	    ppr PprForUser tycon, ppSP,
+	    ppInterleave ppSP (map pp_data_con (getTyConDataCons tycon)),
+	    ppSemi
+    	]
+      where
+	pp_data_con data_con
+	  = ppCat [ppr PprForUser data_con, ppInt (getDataConArity data_con)]
+-}
+\end{code}
diff --git a/ghc/compiler/envs/TVE.hi b/ghc/compiler/envs/TVE.hi
new file mode 100644
index 0000000000..f4bc96a76a
--- /dev/null
+++ b/ghc/compiler/envs/TVE.hi
@@ -0,0 +1,42 @@
+{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
+interface TVE where
+import Class(Class)
+import Id(Id)
+import Maybes(Labda)
+import Name(Name)
+import NameTypes(FullName, ShortName)
+import PreludePS(_PackedString)
+import TyCon(TyCon)
+import TyVar(TyVar, TyVarTemplate)
+import UniType(UniType)
+import UniqFM(UniqFM, eltsUFM, emptyUFM, plusUFM, singletonDirectlyUFM)
+import Unique(Unique, u2i)
+data Labda a 	{-# GHC_PRAGMA Hamna | Ni a #-}
+data Name 	{-# GHC_PRAGMA Short Unique ShortName | WiredInTyCon TyCon | WiredInVal Id | PreludeVal Unique FullName | PreludeTyCon Unique FullName Int Bool | PreludeClass Unique FullName | OtherTyCon Unique FullName Int Bool [Name] | OtherClass Unique FullName [Name] | OtherTopId Unique FullName | ClassOpName Unique Name _PackedString Int | Unbound _PackedString #-}
+type TVE = UniqFM UniType
+data TyVarTemplate 	{-# GHC_PRAGMA SysTyVarTemplate Unique _PackedString | UserTyVarTemplate Unique ShortName #-}
+data UniType 	{-# GHC_PRAGMA UniTyVar TyVar | UniFun UniType UniType | UniData TyCon [UniType] | UniSyn TyCon [UniType] UniType | UniDict Class UniType | UniTyVarTemplate TyVarTemplate | UniForall TyVarTemplate UniType #-}
+data UniqFM a 	{-# GHC_PRAGMA EmptyUFM | LeafUFM Int# a | NodeUFM Int# Int# (UniqFM a) (UniqFM a) #-}
+eltsUFM :: UniqFM a -> [a]
+	{-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-}
+emptyUFM :: UniqFM a
+	{-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 1 0 X 1 _/\_ u0 -> _!_ _ORIG_ UniqFM EmptyUFM [u0] [] _N_ #-}
+lookupTVE :: UniqFM UniType -> Name -> UniType
+	{-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _S_ "SS" _N_ _N_ #-}
+lookupTVE_NoFail :: UniqFM a -> Name -> Labda a
+	{-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _S_ "SS" _N_ _N_ #-}
+mkTVE :: [Name] -> (UniqFM UniType, [TyVarTemplate], [UniType])
+	{-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
+nullTVE :: UniqFM UniType
+	{-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _!_ _ORIG_ UniqFM EmptyUFM [UniType] [] _N_ #-}
+plusTVE :: UniqFM UniType -> UniqFM UniType -> UniqFM UniType
+	{-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _TYAPP_  _ORIG_ UniqFM plusUFM { UniType } _N_ #-}
+plusUFM :: UniqFM a -> UniqFM a -> UniqFM a
+	{-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ #-}
+singletonDirectlyUFM :: Unique -> a -> UniqFM a
+	{-# GHC_PRAGMA _A_ 2 _U_ 12 _N_ _S_ "U(P)L" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: Int#) (u2 :: u0) -> _!_ _ORIG_ UniqFM LeafUFM [u0] [u1, u2] _N_} _F_ _IF_ARGS_ 1 2 CX 4 _/\_ u0 -> \ (u1 :: Unique) (u2 :: u0) -> case u1 of { _ALG_ _ORIG_ Unique MkUnique (u3 :: Int#) -> _!_ _ORIG_ UniqFM LeafUFM [u0] [u3, u2]; _NO_DEFLT_ } _N_ #-}
+u2i :: Unique -> Int#
+	{-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(P)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: Int#) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: Unique) -> case u0 of { _ALG_ _ORIG_ Unique MkUnique (u1 :: Int#) -> u1; _NO_DEFLT_ } _N_ #-}
+unitTVE :: Unique -> a -> UniqFM a
+	{-# GHC_PRAGMA _A_ 2 _U_ 12 _N_ _S_ "U(P)L" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: Int#) (u2 :: u0) -> _!_ _ORIG_ UniqFM LeafUFM [u0] [u1, u2] _N_} _F_ _IF_ARGS_ 1 2 CX 4 _/\_ u0 -> \ (u1 :: Unique) (u2 :: u0) -> case u1 of { _ALG_ _ORIG_ Unique MkUnique (u3 :: Int#) -> _!_ _ORIG_ UniqFM LeafUFM [u0] [u3, u2]; _NO_DEFLT_ } _N_ #-}
+
diff --git a/ghc/compiler/envs/TVE.lhs b/ghc/compiler/envs/TVE.lhs
new file mode 100644
index 0000000000..ab927df407
--- /dev/null
+++ b/ghc/compiler/envs/TVE.lhs
@@ -0,0 +1,74 @@
+%
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1994
+%
+\section[TVE]{Type variable environment}
+
+This environment is not part of the big one that is carried around
+monadically.
+
+\begin{code}
+#include "HsVersions.h"
+
+module TVE (
+	TVE(..), UniqFM,
+
+	mkTVE, nullTVE, unitTVE,
+	lookupTVE, lookupTVE_NoFail, plusTVE,
+
+	-- and to make the interface self-sufficient...
+	Maybe, Name, TyVarTemplate, UniType
+
+	IF_ATTACK_PRAGMAS(COMMA emptyUFM COMMA plusUFM)
+	IF_ATTACK_PRAGMAS(COMMA eltsUFM  COMMA singletonDirectlyUFM)
+	IF_ATTACK_PRAGMAS(COMMA u2i)
+    ) where
+
+import AbsUniType	( mkUserTyVarTemplate, mkTyVarTemplateTy,
+			  getTyVar, TyVarTemplate, TyVar, Class,
+			  ClassOp, Arity(..), TyCon,
+			  TauType(..), UniType
+			  IF_ATTACK_PRAGMAS(COMMA cmpTyCon COMMA cmpClass)
+			  IF_ATTACK_PRAGMAS(COMMA cmpTyVar)
+			  IF_ATTACK_PRAGMAS(COMMA cmpUniType)
+			)
+import Maybes		( Maybe(..), MaybeErr(..) )
+import Name
+import Outputable	-- def of ppr
+import Pretty		-- to pretty-print error messages
+import UniqFM		-- basic environment handling
+import Unique		( Unique )
+import Util
+\end{code}
+
+\begin{code}
+type TVE = UniqFM UniType
+#define MkTVE {--}
+-- also: export non-abstractly
+
+mkTVE :: [Name] -> (TVE, [TyVarTemplate], [TauType])
+mkTVE names
+  = case (unzip3 (map mk_tve_one names)) of { (env, tyvars, tys) ->
+    (MkTVE (listToUFM_Directly env), tyvars, tys) }
+  where
+    mk_tve_one (Short uniq short_name)
+      = case (mkUserTyVarTemplate uniq short_name)  of { tyvar ->
+	case (mkTyVarTemplateTy tyvar)		    of { ty ->
+    	((uniq, ty), tyvar, ty) }}
+
+nullTVE :: TVE
+nullTVE = MkTVE emptyUFM
+
+unitTVE u ty = MkTVE (singletonDirectlyUFM u ty)
+
+lookupTVE :: TVE -> Name -> UniType
+lookupTVE (MkTVE tve) (Short uniq short_name)
+ = case (lookupDirectlyUFM tve uniq) of
+     Just ty -> ty
+     Nothing -> panic "lookupTVE!"
+
+lookupTVE_NoFail (MkTVE tve) (Short uniq short_name)
+ = lookupDirectlyUFM tve uniq
+
+plusTVE :: TVE -> TVE -> TVE
+plusTVE (MkTVE tve1) (MkTVE tve2) = MkTVE (plusUFM tve1 tve2)
+\end{code}
diff --git a/ghc/compiler/envs/TyVarEnv.hi b/ghc/compiler/envs/TyVarEnv.hi
new file mode 100644
index 0000000000..1330078eec
--- /dev/null
+++ b/ghc/compiler/envs/TyVarEnv.hi
@@ -0,0 +1,54 @@
+{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
+interface TyVarEnv where
+import Maybes(Labda(..))
+import NameTypes(ShortName)
+import Outputable(NamedThing)
+import TyVar(TyVar)
+import UniType(UniType)
+import UniqFM(UniqFM, addToUFM, delFromUFM, delListFromUFM, eltsUFM, emptyUFM, listToUFM, lookupUFM, mapUFM, minusUFM, plusUFM, plusUFM_C, singletonUFM)
+import Unique(Unique, u2i)
+data Labda a   = Hamna | Ni a
+data TyVar 	{-# GHC_PRAGMA PrimSysTyVar Unique | PolySysTyVar Unique | OpenSysTyVar Unique | UserTyVar Unique ShortName #-}
+type TyVarEnv a = UniqFM a
+type TypeEnv = UniqFM UniType
+data UniqFM a 	{-# GHC_PRAGMA EmptyUFM | LeafUFM Int# a | NodeUFM Int# Int# (UniqFM a) (UniqFM a) #-}
+data Unique 	{-# GHC_PRAGMA MkUnique Int# #-}
+addOneToTyVarEnv :: UniqFM a -> TyVar -> a -> UniqFM a
+	{-# GHC_PRAGMA _A_ 3 _U_ 222 _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _SPEC_ _ORIG_ UniqFM addToUFM [ (TyVar), _N_ ] _N_ #-}
+addToUFM :: NamedThing a => UniqFM b -> a -> b -> UniqFM b
+	{-# GHC_PRAGMA _A_ 4 _U_ 1222 _N_ _S_ "U(AAAAAASAAA)SLL" {_A_ 4 _U_ 1222 _N_ _N_ _N_ _N_} _N_ _SPECIALISE_ [ Name, _N_ ] 1 { _A_ 3 _U_ 222 _N_ _S_ "SSL" _N_ _N_ }, [ TyVar, _N_ ] 1 { _A_ 3 _U_ 222 _N_ _S_ "SSL" _N_ _N_ }, [ Id, _N_ ] 1 { _A_ 3 _U_ 212 _N_ _S_ "SU(U(P)AAA)L" {_A_ 3 _U_ 222 _N_ _N_ _N_ _N_} _N_ _N_ } #-}
+delFromUFM :: NamedThing a => UniqFM b -> a -> UniqFM b
+	{-# GHC_PRAGMA _A_ 3 _U_ 122 _N_ _S_ "U(AAAAAASAAA)SL" {_A_ 3 _U_ 122 _N_ _N_ _N_ _N_} _N_ _SPECIALISE_ [ Name, _N_ ] 1 { _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ }, [ TyVar, _N_ ] 1 { _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ }, [ Id, _N_ ] 1 { _A_ 2 _U_ 21 _N_ _S_ "SU(U(P)AAA)" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_ } #-}
+delListFromUFM :: NamedThing a => UniqFM b -> [a] -> UniqFM b
+	{-# GHC_PRAGMA _A_ 3 _U_ 221 _N_ _N_ _N_ _SPECIALISE_ [ Name, _N_ ] 1 { _A_ 2 _U_ 21 _N_ _S_ "LS" _N_ _N_ }, [ TyVar, _N_ ] 1 { _A_ 2 _U_ 21 _N_ _S_ "LS" _N_ _N_ }, [ Id, _N_ ] 1 { _A_ 2 _U_ 21 _N_ _S_ "LS" _N_ _N_ } #-}
+eltsUFM :: UniqFM a -> [a]
+	{-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-}
+emptyUFM :: UniqFM a
+	{-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 1 0 X 1 _/\_ u0 -> _!_ _ORIG_ UniqFM EmptyUFM [u0] [] _N_ #-}
+growTyVarEnvList :: UniqFM a -> [(TyVar, a)] -> UniqFM a
+	{-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ #-}
+isNullTyVarEnv :: UniqFM a -> Bool
+	{-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
+listToUFM :: NamedThing a => [(a, b)] -> UniqFM b
+	{-# GHC_PRAGMA _A_ 2 _U_ 11 _N_ _S_ "LS" _N_ _SPECIALISE_ [ Name, _N_ ] 1 { _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ }, [ TyVar, _N_ ] 1 { _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ }, [ Id, _N_ ] 1 { _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ } #-}
+lookupTyVarEnv :: UniqFM a -> TyVar -> Labda a
+	{-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _SPEC_ _ORIG_ UniqFM lookupUFM [ (TyVar), _N_ ] _N_ #-}
+lookupUFM :: NamedThing a => UniqFM b -> a -> Labda b
+	{-# GHC_PRAGMA _A_ 3 _U_ 122 _N_ _S_ "U(AAAAAASAAA)SL" {_A_ 3 _U_ 122 _N_ _N_ _N_ _N_} _N_ _SPECIALISE_ [ Name, _N_ ] 1 { _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ }, [ TyVar, _N_ ] 1 { _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ }, [ Id, _N_ ] 1 { _A_ 2 _U_ 21 _N_ _S_ "SU(U(P)AAA)" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_ } #-}
+mapUFM :: (a -> b) -> UniqFM a -> UniqFM b
+	{-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "LS" _N_ _N_ #-}
+minusUFM :: UniqFM a -> UniqFM a -> UniqFM a
+	{-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "SL" _N_ _N_ #-}
+mkTyVarEnv :: [(TyVar, a)] -> UniqFM a
+	{-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _SPEC_ _ORIG_ UniqFM listToUFM [ (TyVar), _N_ ] _N_ #-}
+nullTyVarEnv :: UniqFM a
+	{-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 1 0 X 1 _/\_ u0 -> _!_ _ORIG_ UniqFM EmptyUFM [u0] [] _N_ #-}
+plusUFM :: UniqFM a -> UniqFM a -> UniqFM a
+	{-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ #-}
+plusUFM_C :: (a -> a -> a) -> UniqFM a -> UniqFM a -> UniqFM a
+	{-# GHC_PRAGMA _A_ 3 _U_ 222 _N_ _S_ "LSS" _N_ _N_ #-}
+singletonUFM :: NamedThing a => a -> b -> UniqFM b
+	{-# GHC_PRAGMA _A_ 3 _U_ 122 _N_ _S_ "U(AAAAAASAAA)LL" {_A_ 3 _U_ 122 _N_ _N_ _F_ _IF_ARGS_ 2 3 XXX 6 _/\_ u0 u1 -> \ (u2 :: u0 -> Unique) (u3 :: u0) (u4 :: u1) -> case _APP_  u2 [ u3 ] of { _ALG_ _ORIG_ Unique MkUnique (u5 :: Int#) -> _!_ _ORIG_ UniqFM LeafUFM [u1] [u5, u4]; _NO_DEFLT_ } _N_} _F_ _IF_ARGS_ 2 3 CXX 7 _/\_ u0 u1 -> \ (u2 :: {{NamedThing u0}}) (u3 :: u0) (u4 :: u1) -> case case u2 of { _ALG_ _TUP_10 (u5 :: u0 -> ExportFlag) (u6 :: u0 -> Bool) (u7 :: u0 -> (_PackedString, _PackedString)) (u8 :: u0 -> _PackedString) (u9 :: u0 -> [_PackedString]) (ua :: u0 -> SrcLoc) (ub :: u0 -> Unique) (uc :: u0 -> Bool) (ud :: u0 -> UniType) (ue :: u0 -> Bool) -> _APP_  ub [ u3 ]; _NO_DEFLT_ } of { _ALG_ _ORIG_ Unique MkUnique (uf :: Int#) -> _!_ _ORIG_ UniqFM LeafUFM [u1] [uf, u4]; _NO_DEFLT_ } _SPECIALISE_ [ Name, _N_ ] 1 { _A_ 2 _U_ 22 _N_ _S_ "SL" _N_ _N_ }, [ TyVar, _N_ ] 1 { _A_ 2 _U_ 22 _N_ _S_ "SL" _N_ _N_ }, [ Id, _N_ ] 1 { _A_ 2 _U_ 12 _N_ _S_ "U(U(P)AAA)L" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: Int#) (u2 :: u0) -> _!_ _ORIG_ UniqFM LeafUFM [u0] [u1, u2] _N_} _F_ _IF_ARGS_ 1 2 CX 5 _/\_ u0 -> \ (u1 :: Id) (u2 :: u0) -> case u1 of { _ALG_ _ORIG_ Id Id (u3 :: Unique) (u4 :: UniType) (u5 :: IdInfo) (u6 :: IdDetails) -> case u3 of { _ALG_ _ORIG_ Unique MkUnique (u7 :: Int#) -> _!_ _ORIG_ UniqFM LeafUFM [u0] [u7, u2]; _NO_DEFLT_ }; _NO_DEFLT_ } _N_ } #-}
+u2i :: Unique -> Int#
+	{-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(P)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: Int#) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: Unique) -> case u0 of { _ALG_ _ORIG_ Unique MkUnique (u1 :: Int#) -> u1; _NO_DEFLT_ } _N_ #-}
+
diff --git a/ghc/compiler/envs/TyVarEnv.lhs b/ghc/compiler/envs/TyVarEnv.lhs
new file mode 100644
index 0000000000..421b4a2121
--- /dev/null
+++ b/ghc/compiler/envs/TyVarEnv.lhs
@@ -0,0 +1,71 @@
+%
+% (c) The AQUA Project, Glasgow University, 1994
+%
+\section[TyVarEnv]{Lookup tables that have @TyVar@ keys}
+
+An interface to the @FiniteMap@ machinery, which exports
+a ``personality'' the same as that of the old @TyVarEnv@ module.
+
+\begin{code}
+#include "HsVersions.h"
+
+module TyVarEnv (
+	TyVarEnv(..),  -- abstract: NOT
+
+	TypeEnv(..),	-- most common/important kind of TyVarEnv
+
+	mkTyVarEnv,
+	lookupTyVarEnv,
+	nullTyVarEnv, growTyVarEnvList,
+	isNullTyVarEnv,
+	addOneToTyVarEnv,
+
+	-- and to make the interface self-sufficient...
+	UniqFM,
+	TyVar, Unique, Maybe(..)
+	
+#ifdef USE_ATTACK_PRAGMAS
+	, addToUFM, plusUFM_C, delListFromUFM, delFromUFM, plusUFM,
+	lookupUFM, mapUFM, minusUFM, listToUFM, emptyUFM, eltsUFM,
+	singletonUFM,
+	u2i
+#endif
+    ) where
+
+import AbsUniType
+import UniqFM
+import Maybes		( Maybe(..) )
+import Outputable
+import Unique		( Unique, u2i )
+import Util
+\end{code}
+
+\begin{code}
+type TyVarEnv elt = UniqFM elt
+
+type TypeEnv = TyVarEnv UniType -- most common flavo(u)r
+\end{code}
+
+Signatures:
+\begin{code}
+mkTyVarEnv :: [(TyVar, a)] -> TyVarEnv a
+addOneToTyVarEnv :: TyVarEnv a -> TyVar -> a -> TyVarEnv a
+growTyVarEnvList :: TyVarEnv a -> [(TyVar, a)] -> TyVarEnv a
+isNullTyVarEnv :: TyVarEnv a -> Bool
+lookupTyVarEnv :: TyVarEnv a -> TyVar -> Maybe a
+nullTyVarEnv :: TyVarEnv a
+\end{code}
+
+\begin{code}
+mkTyVarEnv stuff = listToUFM stuff
+
+addOneToTyVarEnv env id elt = addToUFM env id elt
+
+growTyVarEnvList env pairs = plusUFM env (listToUFM pairs)
+
+isNullTyVarEnv env = sizeUFM env == 0
+
+lookupTyVarEnv env id = lookupUFM env id
+
+nullTyVarEnv = emptyUFM
+\end{code}